8. EPMO Open Source Coordination Office Redaction File Detail Report

Produced by Araxis Merge on 4/24/2018 3:32:28 PM Eastern Daylight Time. See www.araxis.com for information about Merge. This report uses XHTML and CSS2, and is best viewed with a modern standards-compliant browser. For optimum results when printing this report, use landscape orientation and enable printing of background images and colours in your browser.

8.1 Files compared

# Location File Last Modified
1 CPEE_v1_Build_7.zip\CPEE_v1_Build_7\Build 7 - Sprint 15\CPE001-119 - CMAC payment methodology for Multiple Surgery CHFBC2A Developer Form.docx Tue Apr 24 15:18:40 2018 UTC
2 CPEE_v1_Build_7.zip\CPEE_v1_Build_7\Build 7 - Sprint 15\CPE001-119 - CMAC payment methodology for Multiple Surgery CHFBC2A Developer Form.docx Tue Apr 24 18:24:32 2018 UTC

8.2 Comparison summary

Description Between
Files 1 and 2
Text Blocks Lines
Unchanged 1 110
Changed 0 0
Inserted 0 0
Removed 0 0

8.3 Comparison options

Whitespace
Character case Differences in character case are significant
Line endings Differences in line endings (CR and LF characters) are ignored
CR/LF characters Not shown in the comparison detail

8.4 Active regular expressions

No regular expressions were active.

8.5 Comparison detail

  1   Routine Na me:  CHFBC 2A_____                 ____
  2   Developer  Name(s):   __Cindy St iles______ __________ __
  3   Associated  User Stor y/Stories:     ___CPE 001-119___ __________ _____
  4   Current ve rsion (Por tions that  are added  to, modif ied or del eted [Matc h up with  New Versio n section)
  5  
  6   ZCFSCHFBC2 Ab ;HAC/CR ;GETS ALLO WABLE AMOU NTS FOR OP  PROC;04/2 9/99 3:27  PM ;;1.0;C HAMPVA SYS TEM;;JULY  4, 1990;Bu ild 2 ;CPT S #10846*,  11233*, # 11736* (DT P,4-23-97)  ;CPTS #10 292*, 7/8/ 97 *CR* ;C PTS #11937 * 7/11/97  *CR* ;CPTS  #6298 7/1 5/97 *CR*  ;CPTS #137 33 BY DTP  (13-FEB-98 )* ;CPTS # 14619 BY J LR* ;CPTS  #14051 BY  JLR (20-JU L-98)* ;CP TS #16182  (Y2K) - fi xed FN num ber for pr evailing f ee global  - CHMSPF ; CPTS #1633 6 BY DTP ( 26-MAR-99) * ;CR MC21 5 JEH 8/21 /06 - Modi fied to ac cept new C MAC file f ormat ;TT  DEF004574  JEH 3/25/0 8 - Remove  facility/ non-facili ty calls t o global ^ IBE(353.1  from CHV r outines ;T T ENC00484 3: JEH 2/1 3/09 - Pay ment of CP T codes re quiring TC  or 26 mod ifier ;TT  DEF008917  JAK 03/31/ 10 - Preva iling rate  issue on  DME - HAC  usage of C MS DMEPOS  fee schedu le on DMEs  ;DEF00924 8-03 DPT 4 /08/10 edi t range of  dates for  begin and  terminal  dates,BUG0 09248-03,0 4,05 ;;DEV 006421 DRW  06/11/12  - added Ho spice Paym ent requir ements to  calculate  Hospice pe r diem rat e based on  CBSA and   ;;type of  service ( outpatient  or inpati ent) GLOBA L -- 74100 6.03 (CBSA  cross wal k) ;BUG006 421-04-07  originally  pulling t he most re cent wage  rate. Wage  rate shou ld be date  specific  not by ent ry  ;order . DRW 01/0 4/13. ;DEF 016763 DPT  4/28/14 -  REJECT 19 6 IF DOS I S OUTSIDE  DATE RANGE  FOR CODES  ;BUG01676 3 DPT 4/30 /14 - CORR ECT BUG ;D EV004651 2 /11/14 EW  - FLAG ADD ED SO CMAC  CALC CAN  BE USED FO R WIP REPO RT ;Warnin g CHFBC2 a nd CHFBC2D  must have  the above  change pr esent if t his routin e has the  change ;DE V021956 Mo dify routi ne to allo w for corr ect wage r ate to be  applied wh en  ;effec tive date  falls on t he same da y as Date  Of Service . DRW 10/2 2/2014 ;DE V022592 JS E 3/3/15 -  FIX SUBSC RIPT ERROR  (NEXT+11)  ;DEV02563 3 RFE 6/30 /16 Correc t subscrip t error in  GETMOD ;n sd I184390 16FY18 - d pt 1/24/18  ;CPE001-0 02 PL-ZIP  05/24/2017  GEF ; S C HMPF=0,CHM PFD="",HOS PAMT=0 K A LLOW S CHA DOS=$P(REC 0,"^",8) G  PF:CHADOS <2921001 S  VI=$P(REC 0,"^",3) Q :VI="" ;I  $D(^CHMVEN (VI,1)) I  $P(^(1),"^ ",16)=1 G  END:K2="DM E-SUPPLY"  ; JAK - 03 /31/10 - D EF008917 G  END:$P(RE C0,"^",27) =2 S RECC= @(GLPAY_"C I,""COMMON "")") ;PHP   ;  G HOS PCE:CHADOS <2970801 G  HOSPCE:$P (RECC,"^", 2)=""                       ;;DE V006421 --  added lin e tag HOSP CE (orgina lly, ASC)  G HOSPCE:$ P(^CHMDIC( 741002.11, $P(RECC,"^ ",2),0),"^ ",1)'="PHP "  ;CHECKI NG FACILIT Y TYPE G H OSPCE:'$D( ^CHMDIC(74 1013.13,"B ",$P(@(GLP AY_"CI,K2, NM,0)"),"^ ",1))) ;CH ECKING PHP  CODES ; C PE VENDOR  STREAMLINI NG Replace  Provider  zip with P L-ZIP gef  ;I '$D(^CH MVEN(VI,2) ) S CHMFQU E=10,CHMMD P=CHMMDP_" : VENDOR Z IP MISSING " G END ;S  VZ=$E($P( ^CHMVEN(VI ,2),"^",5) ,1,5) ;I V Z="" S CHM FQUE=10,CH MMDP=CHMMD P_": VENDO R ZIP MISS ING" G END  S VZ=$E($ P($G(^CHMP AY(CI,"VEN -II")),"^" ,15),1,5)  I VZ="" S  CHMFQUE=10 ,CHMMDP=CH MMDP_": PL -ZIP MISSI NG" G END  S VC=$O(^C HMSMSA("ZI P",VZ,0))  G HOSPCE:' VC G HOSPC E:'$D(^CHM SMSA(VC,4, 0)) S PHPD AT=$O(^CHM SMSA(VC,4, "B",CHADOS ),-1) G HO SPCE:'PHPD AT S PHPI= $O(^CHMSMS A(VC,4,"B" ,PHPDAT,0) ) G HOSPCE :'PHPI G H OSPCE:'$D( ^CHMSMSA(V C,4,PHPI,0 )) S PHPF= $O(^CHMDIC (741013.13 ,"B",$P(@( GLPAY_"CI, K2,NM,0)") ,"^",1),0) ) G HOSPCE :'PHPF S F DHD=$P(^CH MDIC(74101 3.13,PHPF, 0),"^",2)  S CHMPF=$P (^CHMSMSA( VC,4,PHPI, 0),"^",FDH D) G HOSPC E:+CHMPF=0  S CMAC(NM )=CHMPF S  $P(@(GLPAY _"CI,""RUL E-PROC"",N M,0)"),"^" ,9)=5 G EN DHOSPCE  ;  DEV006421  incorpora ting a new  payment r equirement  for hospi ce payment  N IEN,NM1 ,CBSA,CBSA IEN,CBSAIE N1,CBSANM, CBSANM1,CB SAWC,CBSAN WA,CBSAWG, CBSAENT,CB SAENT1             ;; DEV006421  new variab les added  for this s ection G A SC:CHADOS< 2970801 ;; this code  from here  to END is  new for DE V006421 -  DRW - 06/1 5/12 G ASC :$P(RECC," ^",16)'=5  ;;5 indica tes outpat ient  S FL G=0 I $P(R ECC,"^",2) ="" G NEXT  I $P(^CHM DIC(741002 .11,$P(REC C,"^",2),0 ),"^",1)=" HPC" S FLG =FLG+1 ;;h ospice fac ility type NEXT  ; in  order to  avoid subs cript erro r if facil ity type n ot defined   S CHMSP= $P(@(GLPAY _"CI,K2,NM ,0)"),"^") ,CHMSPC=$P (^CHMSERV( CHMSP,0)," ^",1) ;;CH MSP contai ns pointer  to CHMSER V and CHMS PC is the  service co de returne d from CHM SERV  G:(C HMSPC'="X7 000")&(CHM SPC'="X700 1")&(CHMSP C'="00.00" )&(CHMSPC' ="00.99")  ASC ; CPE  VENDOR STR EAMLINING  Replace Pr ovider zip  with PL-Z IP gef ;I  '$D(^CHMVE N(VI,2)) S  CHMFQUE=1 0,CHMMDP=C HMMDP_": V ENDOR ZIP  MISSING" G  END ;S VZ =$E($P(^CH MVEN(VI,2) ,"^",5),1, 5)  ;I VZ= "" S CHMFQ UE=10,CHMM DP=CHMMDP_ ": VENDOR  ZIP MISSIN G" G END   S VZ=$E($P ($G(^CHMPA Y(CI,"VEN- II")),"^", 15),1,5) I  VZ="" S C HMFQUE=10, CHMMDP=CHM MDP_": PL- ZIP MISSIN G" G END S  IEN=$O(^C HMDIC(7410 06.03,"B", VZ,0)) ;;f ind the IE N for the  CBSA cross walk based  on zip ;  ;;DEV02259 2 JSE 3/3/ 15 WAGE RA TE NEVER S ET CORRECT LY B/C NM1  WAS NEVER  SET TO TH E CORRECT  DIC LOOKUP   ;; COMME NT OUT HOW  NM1 WAS O RIGINALY S ET & THE A TTEMPTED F IX FROM DE V021956 (B ELOW) ;S N M1=$O(^CHM DIC(741006 .03,IEN,1, CHADOS),-1 ) ;; ORIG  CODE INCOR RECT, CAUS ING SUBSCR IPT ERRS ; CHECKDT; I F DOS IS N OT CHECKED , THE IEN  ABOVE MAY  NOT BE THE  CORRECT C BSA ;; DEV 021956 DRW  11/06/201 4  ;S EFFD T=$P(^CHMD IC(741006. 03,IEN,1,N M1,0),"^", 1) ;; DEV0 21956 DRW  11/06/2014   ;I CHADO S<EFFDT S  NM1=NM1-1  G CHECKDT  ;;LOOP THR OUGH UNTIL  DOS IS NO  LONGER LE SS THAN EF FECTIVE DA TE  ; ;;DE V022592 JS E - NEW LO GIC(BELOW)  CORRECTLY  SETS NM1.  THIS LOGI C REPLACE  THE LOGIC  ABOVE. I $ D(^CHMDIC( 741006.03, IEN,1,"B", CHADOS)) S  CHADOS2=C HADOS         ;; DEV0 22592 JSE  - IF DOS H AS AN ENTR Y USE DOS  DATE E  S  CHADOS2=$O (^CHMDIC(7 41006.03,I EN,1,"B",C HADOS),-1)  ;; DEV022 592 JSE -  IF NO DOS  ENTRY, USE  DATE B4 D OS I CHADO S2="" S CH ADOS2=$O(^ CHMDIC(741 006.03,IEN ,1,"B",0))  ;; DEV022 592 JSE -  IF DOS IS  B4 THE 1ST  ENT, SET  NM1=1ST EN T S NM1=$O (^CHMDIC(7 41006.03,I EN,1,"B",C HADOS2,"") ) ;; DEV02 2592 JSE -  SET NM1 T O ENTRY# 4  SELECTED  DATE ; S C BSA=$P(^CH MDIC(74100 6.03,IEN,1 ,NM1,0),"^ ",5) ;;onc e the CBSA  is found,  use the C BSA to fin d the wage  index on  global ^CH MDIC(74104 3 S CBSAIE N=$O(^CHMD IC(741043, "B",CBSA,0 )) ;S CBSA NM=$O(^CHM DIC(741043 ,CBSAIEN,1 ,"B",CHADO S),-1) ;;  Find the l ast entry  close to t he DOS (re verse orde r)) I $D(^ CHMDIC(741 043,CBSAIE N,1,"B",CH ADOS)) S C BSANM=CHAD OS         ;; DEV0219 56 DRW - A DDED IF/EL SE FOR EFF ECTIVE DAT E E  S CBS ANM=$O(^CH MDIC(74104 3,CBSAIEN, 1,"B",CHAD OS),-1) ;;  DEV021956  Find last  entry clo sest to DO S (rev. or der)) I CB SANM="" S  CBSANM=$O( ^CHMDIC(74 1043,CBSAI EN,1,"B",C HADOS)) S  CBSAENT=$O (^CHMDIC(7 41043,CBSA IEN,1,"B", CBSANM,0))  ;;find th e physical  location  of the ent ry number  S CBSAWG=$ P(^CHMDIC( 741043,CBS AIEN,1,CBS AENT,0),"^ ",6) ;;wag e index ra te for the  hospice c laim ;;onc e the CBSA WG is foun d, use the  formula r ate associ ated with  the servic e code in  ;;global ^ CHMDIC(741 045 to det ermine the  hospice p er diem ra te S CBSAI EN1=$O(^CH MDIC(74104 5,"B",CHMS PC,0)) ;S  CBSANM1=$O (^CHMDIC(7 41045,CBSA IEN1,1,"B" ,CHADOS),- 1) I $D(^C HMDIC(7410 45,CBSAIEN 1,1,"B",CH ADOS)) S C BSANM1=CHA DOS      ; ;DEV021956  DRW-ADDED  IF/ELSE F OR EFFECTI VE DATE E   S CBSANM1 =$O(^CHMDI C(741045,C BSAIEN1,1, "B",CHADOS ),-1) I CB SANM1="" S  CBSANM1=$ O(^CHMDIC( 741045,CBS AIEN1,1,"B ",CHADOS))  S CBSAENT 1=$O(^CHMD IC(741045, CBSAIEN1,1 ,"B",CBSAN M1,0)) ;;f ind the en try locati on of date  S CBSAWC= $P(^CHMDIC (741045,CB SAIEN1,1,C BSAENT1,0) ,"^",4) ;; find the w age compon ent S CBSA NWA=$P(^CH MDIC(74104 5,CBSAIEN1 ,1,CBSAENT 1,0),"^",5 ) ;;find t he non-wei ghted amou nt S HOSPA MT=(CBSAWC *CBSAWG)+C BSANWA                            ;;multipl y wage com ponent by  the CBSA i ndex + non -weighted  amt I CHMS PC="X7001"  D . S HOS PAMT=HOSPA MT/24 ;;di vide by th e number o f hours in  one day t o get dail y rate S H OSPAMT=$FN (HOSPAMT," ",2) ;;the  $FN funct ion rounds  & sets to  two decim al places  S CHMPF=+H OSPAMT S C MAC(NM)=CH MPF G ENDA SC S CHMSP =$P(@(GLPA Y_"CI,K2,N M,0)"),"^" ),CHMSPC=$ P(^CHMSERV (CHMSP,0), "^",1) ; S ubscript e rror 9/30/ 05 mlr G C MAC:$P(REC C,"^",2)=" " G CMAC:$ P(^CHMDIC( 741002.11, $P(RECC,"^ ",2),0),"^ ",1)'="ASC " ; CPE VE NDOR STREA MLINING Re place Prov ider zip w ith PL-ZIP  gef ;I '$ D(^CHMVEN( VI,2)) S C HMFQUE=10, CHMMDP=CHM MDP_": VEN DOR ZIP MI SSING" G E ND G CMAC: $P(^CHMVEN (VI,1),"^" ,7)="" S C HFAC=$P(^( 1),"^",7)  G CMAC:($P (^CHMDIC(7 41002.11,C HFAC,0),"^ ",1)'="ASF ")&($P(^CH MDIC(74100 2.11,CHFAC ,0),"^",1) '="ASH") G  ASC1:'$D( ^CHMAGP("B ",CHMSPC))  ; CPE VEN DOR STREAM LINING Rep lace Provi der zip wi th PL-ZIP  gef ;S VZ= $E($P(^CHM VEN(VI,2), "^",5),1,5 ) ;I VZ=""  S CHMFQUE =10,CHMMDP =CHMMDP_":  VENDOR ZI P MISSING"  G END S V Z=$E($P($G (^CHMPAY(C I,"VEN-II" )),"^",15) ,1,5) I VZ ="" S CHMF QUE=10,CHM MDP=CHMMDP _": PL-ZIP  MISSING"  G END S VC =$O(^CHMDI C(741002.8 2,"B",VZ,0 )) G CMAC: 'VC S CHLD T=$O(^CHMD IC(741002. 82,VC,1,99 99999),-1)  G CMAC:'C HLDT G CMA C:'$D(^CHM DIC(741002 .82,VC,1,C HLDT,0)) S  CHMSA=$P( ^(0),"^",2 ) F JJ=$L( CHMSA):1:3  S CHMSA=" 0"_CHMSA S  CHMGPN=0, CHMGPN=$O( ^CHMAGP("B ",CHMSPC,C HMGPN)) I  'CHMGPN D   ;nsd I184 39016FY18  - dpt    . I $P(^CHMD IC(741002. 11,CHFAC,0 ),"^",1)=" ASF" G ASC 2  ;nsd I1 8439016FY1 8 - dpt     .G CMAC ; :'CHMGPN ; nsd I18439 016FY18 -  dpt  ;I '$ D(^CHMAGP( CHMGPN,1,( CHADOS+1)) ) I $P(^CH MDIC(74100 2.11,CHFAC ,0),"^",1) ="ASF" G A SC2  ;I '$ D(^CHMAGP( CHMGPN,1,( CHADOS+1)) ) I $P(^CH MDIC(74100 2.11,CHFAC ,0),"^",1) '="ASF" G  CMAC  ;I $ D(^CHMAGP( CHMGPN,1,( CHADOS+1)) ) S CHGRDT =$O(^CHMAG P(CHMGPN,1 ,(CHADOS+1 )),-1) I C HGRDT="" D  ; .I $P(^ CHMDIC(741 002.11,CHF AC,0),"^", 1)="ASF" G  ASC2  ; . I $P(^CHMD IC(741002. 11,CHFAC,0 ),"^",1)'= "ASF" G CM AC ;nsd I1 8439016FY1 8 - dpt S  CHGRDT=$O( ^CHMAGP(CH MGPN,1,999 9999),-1)   I CHADOS< CHGRDT  I  $P(^CHMDIC (741002.11 ,CHFAC,0), "^",1)="AS F" G ASC2   ;;nsd I18 439016FY18  - dpt DEF 016763 DPT  3/28/11 D EV009248-0 3 I CHADOS <CHGRDT  I  $P(^CHMDI C(741002.1 1,CHFAC,0) ,"^",1)'=" ASF" G CMA C ;TEST DP T G CMAC:' $D(^CHMAGP (CHMGPN,1, CHGRDT,0))  S CHGRP=+ $P(^(0),"^ ",2) S CHG RP=+$P(^CH MAGP(CHMGP N,1,CHGRDT ,0),"^",2)  ;DPT 8/18 /10 BUG009 248-03 S C HLEDT=+$P( ^CHMAGP(CH MGPN,1,CHG RDT,0),"^" ,3) ;BUG01 6763-03-01  DPT 8/18/ 10 I CHLED T'=0,CHADO S>CHLEDT D   ;;nsd I1 8439016FY1 8 - dpt  . I $P(^CHMD IC(741002. 11,CHFAC,0 ),"^",1)=" ASF"  G AS C2  ;;nsd  I18439016F Y18 - dpt  DPT 3/28/1 1BUG009248 -05  .G CM AC ;;nsd I 18439016FY 18 - dpt S  CHMMPN=0, CHMMPN=$O( ^CHMART("B ",CHMSA,CH MMPN)) G C MAC:'CHMMP N S CHMSDT =$O(^CHMAR T(CHMMPN,1 ,(CHADOS+1 )),-1) G A SC1:'CHMSD T ; DPT 3/ 28/11 BUG0 09248-05 G  CMAC:'$D( ^CHMART(CH MMPN,1,CHM SDT,100,CH GRP,0)) S  CHMPF=+$P( ^(0),"^",1 ) G CMAC:+ CHMPF=0 S  CHMSEDT=+$ P(^CHMART( CHMMPN,1,C HMSDT,0)," ^",2) ;DPT  8/18/10 I  CHMSEDT'= 0,CHADOS>C HMSEDT      .I $P(^CH MDIC(74100 2.11,CHFAC ,0),"^",1) ="ASF" G A SC2  ; ;ns d I1843901 6FY18 - dp t DPT 3/28 /11 DEV009 248-03   . G CMAC  ;n sd I184390 16FY18 - d pt S $P(@( GLPAY_"CI, ""RULE-PRO C"",NM,0)" ),"^",9)=3  ;I WRT=1  S $P(@(GLP AY_"CI,""R ULE-PROC"" ,NM,0)")," ^",9)=3 ;D EV004651 2 /11/14 EW  TEST FOR W RITE FLAG  S CMAC(NM) =CHMPF S $ P(@(GLPAY_ "CI,""COMM ON"")"),"^ ",16)=9 ;I  WRT=1 S $ P(@(GLPAY_ "CI,""COMM ON"")"),"^ ",16)=9 ;D EV004651 2 /11/14 EW  TEST FOR W RITE FLAG  G ENDASC1  S CHMPF=+$ P(@(GLPAY_ "CI,K2,NM, 0)"),"^",2 ),CMAC(NM) =CHMPF S $ P(@(GLPAY_ "CI,""COMM ON"")"),"^ ",16)=9 ;I  WRT=1 S $ P(@(GLPAY_ "CI,""COMM ON"")"),"^ ",16)=9 ;D EV004651 2 /11/14 EW  TEST FOR W RITE FLAG  G ENDASC2  S CHMPF=0, CMAC(NM)=0 ,REA=196,$ P(@(GLPAY_ "CI,""RULE -PROC"",NM ,0)"),"^", 2)=REA G E ND  ;DEF01 6763 DPTCM AC I VI=""  S CHMFQUE =10,CHMMDP =CHMMDP_":  VENDOR ID  MISSING"  G END G PF :'$D(^CHMV EN(VI,41))  S CHCLS=" " D  G PF: CHCLS="" . S CMJ=$O(^ CHMVEN(VI, 41,9999999 ),-1) Q:'C MJ .S CHCL S=$P(^CHMV EN(VI,41,C MJ,0),"^", 3) G PF:"1 ^2^3"'[CHC LS S CHMSP =$P(@(GLPA Y_"CI,K2,N M,0)"),"^" ) S CHMSPC =$P(^CHMSE RV(CHMSP,0 ),"^",1) ; CPE VENDOR  STREAMLIN ING replac e Provider  Zip w/ PL -ZIP gef ; I '$D(^CHM VEN(VI,2))  S VZ="" G  C0 ;S VZ= $E($P(^CHM VEN(VI,2), "^",5),1,5 ) S VZ=$E( $P($G(^CHM PAY(CI,"VE N-II")),"^ ",15),1,5) C0 I VZ=""  S CHMFQUE =10,CHMMDP =CHMMDP_":  PL-ZIP MI SSING" G E ND S VC=$O (^CHMDIC(7 41002.4,"B ",VZ,0)) G  PF:VC=""  S CHLDT=99 99999-CHAD OS-1C1 S C HLDT=$O(^C HMDIC(7410 02.4,VC,1, CHLDT)) G  PF:CHLDT'? 7N G PF:'$ D(^CHMDIC( 741002.4,V C,1,CHLDT, 0)) S CHLO C=$P(^(0), "^",2) S C HMSPN=$O(^ CHMCPF("B" ,CHMSPC,0) ) G PF:'CH MSPN S CHX =0C2 S CHX =$O(^CHMCP F(CHMSPN,C HX)) G C1: 'CHX G:CHX +8>1000 C1  G:CHX+8>C HLOC C22 G  C2C22 S C HCMDT=9999 999-CHADOS -1C3 S CHC MDT=$O(^CH MCPF(CHMSP N,CHX,CHCM DT)) G PF: CHCMDT'?7N  G PF:'$D( ^CHMCPF(CH MSPN,CHX,C HCMDT,0))  S CHLNM=CH LOC#8 S:CH LOC#8=0 CH LNM=8 S CH MREC=$P(^C HMCPF(CHMS PN,CHX,CHC MDT,0),"^" ,2) S CHPN M=$P(CHMRE C,",",CHLN M) D:CHADO S>3070131  GETCLP   ;  JEH 2/1/0 7 CUT-OVER  DATE (2/1 /07) TO NE W CMAC FOR MAT S CHMP F=$P(CHPNM ,";",CHCLS ),MOD="" I  K2="OPT-P ROC" D       ;JEH 2/1 3/09 TT EN C004843 .S  MOD=$$GTM OD^CHFBC2A (CI,K2,NM, CHMSPC) ;J EH 2/13/09  TT ENC004 843 ADDED  SUBROUTINE  ;S:K2="OP T-PROC" MO D=$P(@(GLP AY_"CI,K2, NM,0)"),"^ ",4) ;JEH  2/13/09 TT  ENC004843  S:K2="DEN -PROC" MOD =$P(@(GLPA Y_"CI,K2,N M,0)"),"^" ,6) D:MOD' ="" .Q:CHA DOS<297070 1 .Q:('$D( ^CHMDIC(74 1002.98,"B ",MOD)))&( '$D(^CHMDI C(741002.9 9,"B",MOD) )) .S FILE PT=$S($D(^ CHMDIC(741 002.98,"B" ,MOD)):"74 1002.98",$ D(^CHMDIC( 741002.99, "B",MOD)): "741002.99 ",1:"") .Q :FILEPT=""  .I '$D(^C HMCPF(CHMS PN,CHX,CHC MDT,1)) D   Q         ;PRO/TECH  ..S REA="" ,PERC="" . .S MODI=$O (^CHMDIC(F ILEPT,"B", MOD,0)) .. I MODI'=""  S:$D(^CHM DIC(FILEPT ,MODI,0))  REA=$P(^(0 ),"^",2),P ERC=$P(^(0 ),"^",3) . .S CHMPF=C HMPF*PERC  ..S X1=CI  D PROGTYP^ CHFCD001 . .S $P(@(GL PAY_"CI,K1 ,NM,0)")," ^",2)=REA  ..;I WRT=1  S $P(@(GL PAY_"CI,K1 ,NM,0)")," ^",2)=REA  ;DEV004651  2/11/14 E W TEST FOR  WRITE FLA G ..;S $P( @(GLPAY_"C I,""RULE-P ROC"",NM,0 )"),U,2)=R EA .I CHCL S=2&(CHADO S<3070201)  D  Q      ;JEH 2/11/ 07 ADDED ' CHADOS<307 0201' DUE  TO NEW FOR MAT AND CU TOVER DATE  ..S PERC= "",REA=""  ..S MODI=$ O(^CHMDIC( FILEPT,"B" ,MOD,0)) . .I MODI'=" " S:$D(^CH MDIC(FILEP T,MODI,0))  REA=$P(^( 0),"^",2), PERC=$P(^( 0),"^",3)  ..S CHMPF= CHMPF*PERC  ..S X1=CI  D PROGTYP ^CHFCD001  ..S $P(@(G LPAY_"CI,K 1,NM,0)"), "^",2)=REA  ..;I WRT= 1 S $P(@(G LPAY_"CI,K 1,NM,0)"), "^",2)=REA  ;DEV00465 1 2/11/14  EW TEST FO R WRITE FL AG ..;S $P (@(GLPAY_" CI,""RULE- PROC"",NM, 0)"),U,2)= REA  .S CH MREC1=$P(^ CHMCPF(CHM SPN,CHX,CH CMDT,1),"^ ",2) .S CH PNM1=$P(CH MREC1,",", CHLNM) .;S :FILEPT=74 1002.98 PT 1=CHCLS ;C HAMPVA PRO F COMPONEN T MODIFIER S .;S:FILE PT=741002. 99 PT1=$S( CHCLS=1:2, CHCLS=3:4)  ;CHAMPVA  TECH COMPO NENT MODIF IERS .I FI LEPT=74100 2.98 D                    ;CHAMP VA PROF. C OMPONENT M ODFIERS ;J EH 2/11/07  ADDED FOR  NEW FORMA T AND CUTO VER DATE . .I CHADOS< 3070201 D  ...S PT1=C HCLS ..E   D ...S PT1 =$S(CHCLS= 1:1,CHCLS= 2:1,CHCLS= 3:3,CHCLS= 4:3) .I FI LEPT=74100 2.99 D                    ;CHAMP VA TECH CO MPONENT MO DIFIERS ;J EH 2/11/07  ADDED FOR  NEW FORMA T AND CUTO VER DATE . .I CHADOS< 3070201 D  ...S PT1=$ S(CHCLS=1: 2,CHCLS=3: 4) ..E  D  ...S PT1=$ S(CHCLS=1: 2,CHCLS=2: 2,CHCLS=3: 4,CHCLS=4: 4) .S CHMP F=$P(CHPNM 1,";",PT1)  .S REA=""  .S MODI=$ O(^CHMDIC( FILEPT,"B" ,MOD,0)) . I MODI'=""  S:$D(^CHM DIC(FILEPT ,MODI,0))  REA=$P(^(0 ),"^",2) . S X1=CI D  PROGTYP^CH FCD001 .S  $P(@(GLPAY _"CI,K1,NM ,0)"),"^", 2)=REA .;I  WRT=1 S $ P(@(GLPAY_ "CI,K1,NM, 0)"),"^",2 )=REA ;DEV 004651 2/1 1/14 EW TE ST FOR WRI TE FLAG .; S $P(@(GLP AY_"CI,""R ULE-PROC"" ,NM,0)"),U ,2)=REA  G  PF:+CHMPF =0 S $P(@( GLPAY_"CI, ""RULE-PRO C"",NM,0)" ),"^",9)=1  ;I WRT=1  S $P(@(GLP AY_"CI,""R ULE-PROC"" ,NM,0)")," ^",9)=1 ;D EV004651 2 /11/14 EW  TEST FOR W RITE FLAG  S CMAC(NM) =CHMPF G E NDPF S CHM PF=0,CHMDO S=$P(REC0, "^",8),CHM RDT=999999 9-CHMDOS,C HMRSD=CHMR DT-1 ; Y2K  fix ;S YR =$E(CHMDOS ,2,3) I $E (YR,2)="0"  S YR=$E(Y R,1) ;S FN ="741012." _YR S YR=$ E(CHMDOS,1 ,3) S FN=$ $FNSET^CHF BC2A(CHMDO S) ; S CHM SPC=$P(@(G LPAY_"CI,K 2,NM,0)"), "^") S VI= $P(REC0,"^ ",3) I VI= "" S CHMFQ UE=10,CHMM DP=CHMMDP_ ": VENDOR  ID MISSING " G END ;C PE VENDOR  STREAMLINI NG replace  Provider  Zip w/ PL- ZIP gef ;I  '$D(^CHMV EN(VI,2))  S VZ="" G  A0 ;S VZ=$ E($P(^CHMV EN(VI,2)," ^",5),1,5)  S VZ=$E($ P($G(^CHMP AY(CI,"VEN -II")),"^" ,15),1,5)A 0 I VZ=""  S CHMFQUE= 10,CHMMDP= CHMMDP_":  PL-ZIP MIS SING" G EN D S VST=$P (^(2),"^", 4) I VST=" " S CHMFQU E=10,CHMMD P=CHMMDP_" : VENDOR S TATE MISSI NG " G END  S VC=$O(^ CHMSMSA("Z IP",VZ,VST ,0)) I VC= "" S CHMFQ UE=10,CHMM DP=CHMMDP_ ": PL-ZIP  UNKNOWN OR  INCOMPATI BLE WITH S TATE" G EN D S CHMSPN =$O(^CHMSP F(FN,"B",C HMSPC,0))  G:CHMSPN=" " END I $D (^CHMSPF(F N,CHMSPN," DEL")),$P( ^("DEL")," ^",1)=1 G  END S CHSM DT=$O(^CHM SMSA(VST,1 ,VC,3,CHMR SD)) I CHS MDT'?1N.N  D GSTSM G  A1 S CHMSN UM=$P(^CHM SMSA(VST,1 ,VC,3,CHSM DT,0),"^", 2) I (CHMS NUM=0)!(CH MSNUM="")  D GSTSM G  A1 S PF=$S (((CHMSNUM '>20)&(CHM SNUM>0)):1 ,((CHMSNUM '>40)&(CHM SNUM>20)): 2,((CHMSNU M'>60)&(CH MSNUM>40)) :3,((CHMSN UM'>80)&(C HMSNUM>60) ):4,((CHMS NUM'>100)& (CHMSNUM>8 0)):5,1:6)  I PF=6 D  GSTSM G A1  I CHMSNUM <21,$D(^CH MSPF(FN,CH MSPN,PF))  S:$D(^CHMS PF(FN,CHMS PN,PF)) CH MPFD=$P(^C HMSPF(FN,C HMSPN,PF), ",",CHMSNU M) I CHMPF D'="" S CH MPF=+$P(CH MPFD,";",1 ) E  I $D( ^CHMSPF(FN ,CHMSPN,PF )) S:$D(^C HMSPF(FN,C HMSPN,PF))  CHMPFD=$P (^CHMSPF(F N,CHMSPN,P F),",",(CH MSNUM#(20* ($S(PF=1:1 ,PF=2:1,PF =3:2,PF=4: 3,PF=5:4,1 :1))))) I  CHMPFD'=""  S CHMPF=+ $P(CHMPFD, ";",1) I C HMPF=0 D G STSM:YR>29 3 G END:YR <294 G END :CHMPF=0 S  MOD="" I  K2="OPT-PR OC" D       ;JEH 2/13 /09 TT ENC 004843 .S  TMPSPC=$P( ^CHMSERV(C HMSPC,0)," ^",1) ;GET  CODE .S M OD=$$GTMOD ^CHFBC2A(C I,K2,NM,TM PSPC) ;JEH  2/13/09 T T ENC00484 3 ADDED SU BROUTINE ; S:K2="OPT- PROC" MOD= $P(@(GLPAY _"CI,K2,NM ,0)"),"^", 4) ;JEH 2/ 13/09 TT E NC004843 S :K2="DEN-P ROC" MOD=$ P(@(GLPAY_ "CI,K2,NM, 0)"),"^",6 ) D:MOD'=" " .Q:CHADO S<2970701  .Q:('$D(^C HMDIC(7410 02.98,"B", MOD)))&('$ D(^CHMDIC( 741002.99, "B",MOD)))  .S FILEPT =$S($D(^CH MDIC(74100 2.98,"B",M OD)):"7410 02.98",$D( ^CHMDIC(74 1002.99,"B ",MOD)):"7 41002.99", 1:"") .Q:F ILEPT="" . S PERC="", REA="" .S  MODI=$O(^C HMDIC(FILE PT,"B",MOD ,0)) .I MO DI'="" S:$ D(^CHMDIC( FILEPT,MOD I,0)) REA= $P(^(0),"^ ",2),PERC= $P(^(0),"^ ",3) .S CH MPF=CHMPF* PERC .S X1 =CI D PROG TYP^CHFCD0 01 .S $P(@ (GLPAY_"CI ,K1,NM,0)" ),"^",2)=R EA .;I WRT =1 S $P(@( GLPAY_"CI, K1,NM,0)") ,"^",2)=RE A ;DEV0046 51 2/11/14  EW TEST F OR WRITE F LAG .;S $P (@(GLPAY_" CI,""RULE- PROC"",NM, 0)"),U,2)= REAA1 ;I W RT=1 S $P( @(GLPAY_"C I,""RULE-P ROC"",NM,0 )"),"^",9) =2 ;DEV004 651 2/11/1 4 EW TEST  FOR WRITE  FLAG S $P( @(GLPAY_"C I,""RULE-P ROC"",NM,0 )"),"^",9) =2 S CMAC( NM)=CHMPFE ND I (K2=" DME-SUPPLY ")!(K2="OP T-PROC") D  .Q:$P(@(G LPAY_"CI," "RULE-PROC "",NM,0)") ,"^",9)=19 6 ;DEF0167 63 DPT .Q: $P(@(GLPAY _"CI,K2,NM ,0)"),"^", 5)="" .S C HMPF=$P(^( 0),"^",5), CMAC(NM)=C HMPF .S $P (@(GLPAY_" CI,""RULE- PROC"",NM, 0)"),"^",9 )=4 .;I WR T=1 S $P(@ (GLPAY_"CI ,""RULE-PR OC"",NM,0) "),"^",9)= 4 ;DEV0046 51 2/11/14  EW TEST F OR WRITE F LAG .S ALL OW=1 I K2= "DEN-PROC"  D .Q:$P(@ (GLPAY_"CI ,K2,NM,0)" ),"^",7)=" " .S CHMPF =$P(^(0)," ^",7),CMAC (NM)=CHMPF  .S $P(@(G LPAY_"CI," "RULE-PROC "",NM,0)") ,"^",9)=4  .;I WRT=1  S $P(@(GLP AY_"CI,""R ULE-PROC"" ,NM,0)")," ^",9)=4 ;D EV004651 2 /11/14 EW  TEST FOR W RITE FLAG  .S ALLOW=1  K CHMPFD, CHMSPN,CHM SNUM,CHSMD T,VST,VC,V I,VZ,CHMSP ,CHMSPC,CH LDT K CHMS A,CHMGPN,C HGRDT,CHMM PN,CHMSDT, CHGRP,CHFA C,HOSPAMT  QGSTSM I V ST>40 I $D (^CHMSPF(F N,CHMSPN,0 )) S:$D(^C HMSPF(FN,C HMSPN,103) ) CHMPFD=$ P(^CHMSPF( FN,CHMSPN, 103),",",V ST-40) I $ G(CHMPFD)' ="" S CHMP F=+$P(CHMP FD,";",1)  Q   ;SKD 1 -10-07; I  CHMPFD'=""  I (VST>20 )&(VST'>40 ) I $D(^CH MSPF(FN,CH MSPN,0)) S :$D(^CHMSP F(FN,CHMSP N,102)) CH MPFD=$P(^C HMSPF(FN,C HMSPN,102) ,",",VST-2 0) I $G(CH MPFD)'=""  S CHMPF=+$ P(CHMPFD," ;",1) Q    ;SKD 1-10- 07; I CHMP FD'="" I ( VST>0)&(VS T'>20) I $ D(^CHMSPF( FN,CHMSPN, 0)) S:$D(^ CHMSPF(FN, CHMSPN,101 )) CHMPFD= $P(^CHMSPF (FN,CHMSPN ,101),",", VST) I $G( CHMPFD)'=" " S CHMPF= +$P(CHMPFD ,";",1) Q     ;SKD 1- 10-07; I C HMPFD'=""  QGETCLP ;D ETERMINE C MAC RATE P OSITION Q: $D(^CHMSER V(CHMSP,4) ) ;QUIT IF  ANETHESIA  CODE ; JE H 12/5/06  S CHMFAC=0  ; Set def ault to No n-facility  S CHMPOS= 99 ; Set d efault to  Other loca tion S PTR =""  ;AEB  4/17/2007   S:$D(@(GL PAY_"CI,"" COMMON"")" )) I=$P(@( GLPAY_"CI, ""COMMON"" )"),"^",2)  ;I I I $D (^CHMDIC(7 41002.11,I ,0)) S PTR =$P(^(0)," ^",5) ;JEH  3/25/08 ; I PTR I $D (^IBE(353. 1,PTR,0))  S CHMFAC=$ P(^(0),"^" ,4) ;GET F ACILITY TY PE ;JEH 3/ 25/08 I I  I $D(^CHMD IC(741002. 11,I,0)) S  CHMFAC=$P (^(0),"^", 7) ;JEH 3/ 25/08 S CH CLS=CHCLS+ CHMFAC QFN SET(FMDT)  ;Sets the  correct FN  for preva iling fee  global (CH MSPF) ; FM DT must be  a fileman  date (299 0101) or a t least th e ; first  three posi tions of t he fileman  dt (299)  ; Y2K - Th is was add ed to make  global Y2 K complian t (FN was  741012.99  ; and now  is 741012. 299). Trai ling zeros  will be t runcated i n  ; order  to be com patiable w ith Filema n. ;  N X, Y S Y="" I  $L(FMDT)> 2 D .S X=$ E(FMDT,1,3 ) .I $E(X, 3)=0 S X=$ E(X,1,2) D  ..I $E(X, 2)=0 S X=$ E(X,1) .S  Y="741012. "_X Q YGTM OD(GCI,GK2 ,GNM,GCHMS PC) ;SUBRO UTINE TO D ETERMINE/G ET MODIFIE RS FOR OUT PATIENT CL AIMS ;JEH  4/13/10 EN C004843 ;G CI = CLAIM  POINTER ; GK2 = GLOB AL NODE IN DICATOR -  "OPT-PROC"  ;GNM = J  VALUE FROM  PAY FILE  N MOD,TOB, POS,TOC,CH MREC,CHPNM ,CHMREC1,C HPNM1 S MO D="" S MOD =$P(@(GLPA Y_"GCI,GK2 ,GNM,0)"), "^",4) Q:' $D(^CHMCPF ("B",GCHMS PC)) MOD    ;QUIT IF  CODE NOT I N CMAC GLO BAL Q:MOD= 4!(MOD=83)  MOD  ;4=2 6/83=TC S  TOC="" S T OC=$P(@(GL PAY_"GCI,0 )"),"^",7)  ;TYPE OF  CLAIM 2=OU TPATIENT Q :TOC'=2 MO D Q:CHCMDT ="" MOD                            ; RFE 6/ 30/16 DEV0 25633  I ( GCHMSPC>=7 0000)&(GCH MSPC<=9000 0) {    S  TOB=""   ; BILL TYPE  BILL (013x -HOSP OUTP ATIENT, 01 4x-HOSP OT HER PART B )    S:$D( @(GLPAY_"G CI,7)")) T OB=$P(@(GL PAY_"GCI,7 )"),"^",6)     S POS= 0 S POS=$P (@(GLPAY_" GCI,""COMM ON"")"),"^ ",2) ;PLAC E OF SERVI CE    I TO B'="" {         I ("1 2,13,14,22 ,23,83"[$E (TOB,1,2)) &(POS=2) {       ;BIL L CODE TYP E 013x-Hos pital Outp atient/014 x-Hospital  Other Par t B             I $D( ^CHMCPF(CH MSPN,CHX,C HCMDT,0))  {                 S C HMREC=$P(^ CHMCPF(CHM SPN,CHX,CH CMDT,0),"^ ",2) ;TECH                  S CH PNM=$P(CHM REC,",",CH LNM)                  I $P(CHPNM ,";",4)'=" "&($P(CHPN M,";",4)>0 ) S MOD=83  ;83=TC             }         }     }    I  (TOB=""&(P OS=2))!(PO S=86) {    ;2-OP,86-I PP         I $D(^CHMC PF(CHMSPN, CHX,CHCMDT ,1)) {             S  CHMREC1=$P (^CHMCPF(C HMSPN,CHX, CHCMDT,1), "^",2) ;PR O             S CHPNM 1=$P(CHMRE C1,",",CHL NM)             I $P( CHPNM1,";" ,3)'=""&($ P(CHPNM1," ;",3)>0) S  MOD=4 ;4= 26         }    } } Q  MOD
  7  
  8   New versio n (New or  changed po rtions; Hi ghlight al l of the f ollowing:   New - Bol d, Deleted  - Striket hru, Chang ed - Itali cs)
  9  
  10    CHFBC2A ; HAC/CR;GET S ALLOWABL E AMOUNTS  FOR OP PRO C;04/29/99  3:27 PM ; ;1.0;CHAMP VA SYSTEM; ;JULY 4, 1 990;Build  2 ;CPTS #1 0846*, 112 33*, #1173 6* (DTP,4- 23-97) ;CP TS #10292* , 7/8/97 * CR* ;CPTS  #11937* 7/ 11/97 *CR*  ;CPTS #62 98 7/15/97  *CR* ;CPT S #13733 B Y DTP (13- FEB-98)* ; CPTS #1461 9 BY JLR*  ;CPTS #140 51 BY JLR  (20-JUL-98 )* ;CPTS # 16182 (Y2K ) - fixed  FN number  for prevai ling fee g lobal - CH MSPF ;CPTS  #16336 BY  DTP (26-M AR-99)* ;C R MC215 JE H 8/21/06  - Modified  to accept  new CMAC  file forma t ;TT DEF0 04574 JEH  3/25/08 -  Remove fac ility/non- facility c alls to gl obal ^IBE( 353.1 from  CHV routi nes ;TT EN C004843: J EH 2/13/09  - Payment  of CPT co des requir ing TC or  26 modifie r ;TT DEF0 08917 JAK  03/31/10 -  Prevailin g rate iss ue on DME  - HAC usag e of CMS D MEPOS fee  schedule o n DMEs ;DE F009248-03  DPT 4/08/ 10 edit ra nge of dat es for beg in and ter minal date s,BUG00924 8-03,04,05  ;;DEV0064 21 DRW 06/ 11/12 - ad ded Hospic e Payment  requiremen ts to calc ulate Hosp ice per di em rate ba sed on CBS A and  ;;t ype of ser vice (outp atient or  inpatient)  GLOBAL --  741006.03  (CBSA cro ss walk) ; BUG006421- 04-07 orig inally pul ling the m ost recent  wage rate . Wage rat e should b e date spe cific not  by entry   ;order. DR W 01/04/13 . ;DEF0167 63 DPT 4/2 8/14 - REJ ECT 196 IF  DOS IS OU TSIDE DATE  RANGE FOR  CODES ;BU G016763 DP T 4/30/14  - CORRECT  BUG ;DEV00 4651 2/11/ 14 EW - FL AG ADDED S O CMAC CAL C CAN BE U SED FOR WI P REPORT ; Warning CH FBC2 and C HFBC2D mus t have the  above cha nge presen t if this  routine ha s the chan ge ;DEV021 956 Modify  routine t o allow fo r correct  wage rate  to be appl ied when   ;effective  date fall s on the s ame day as  Date Of S ervice. DR W 10/22/20 14 ;DEV022 592 JSE 3/ 3/15 - FIX  SUBSCRIPT  ERROR (NE XT+11) ;DE V025633 RF E 6/30/16  Correct su bscript er ror in GET MOD ;nsd I 18439016FY 18 - dpt 1 /24/18 ;CP E001-002 P L-ZIP 05/2 4/2017 GEF  ;CFS 03/2 2/18 CPE00 1-119 Fix  Undefined  error caus ed by a Na ked Global  Reference .  ; S CHM PF=0,CHMPF D="",HOSPA MT=0 K ALL OW S CHADO S=$P(REC0, "^",8) G P F:CHADOS<2 921001 S V I=$P(REC0, "^",3) Q:V I="" ;I $D (^CHMVEN(V I,1)) I $P (^(1),"^", 16)=1 G EN D:K2="DME- SUPPLY" ;  JAK - 03/3 1/10 - DEF 008917 G E ND:$P(REC0 ,"^",27)=2  S RECC=@( GLPAY_"CI, ""COMMON"" )") ;PHP   ;  G HOSPC E:CHADOS<2 970801 G H OSPCE:$P(R ECC,"^",2) =""                       ;;DEV0 06421 -- a dded line  tag HOSPCE  (orginall y, ASC) G  HOSPCE:$P( ^CHMDIC(74 1002.11,$P (RECC,"^", 2),0),"^", 1)'="PHP"   ;CHECKING  FACILITY  TYPE G HOS PCE:'$D(^C HMDIC(7410 13.13,"B", $P(@(GLPAY _"CI,K2,NM ,0)"),"^", 1))) ;CHEC KING PHP C ODES ; CPE  VENDOR ST REAMLINING  Replace P rovider zi p with PL- ZIP gef ;I  '$D(^CHMV EN(VI,2))  S CHMFQUE= 10,CHMMDP= CHMMDP_":  VENDOR ZIP  MISSING"  G END ;S V Z=$E($P(^C HMVEN(VI,2 ),"^",5),1 ,5) ;I VZ= "" S CHMFQ UE=10,CHMM DP=CHMMDP_ ": VENDOR  ZIP MISSIN G" G END S  VZ=$E($P( $G(^CHMPAY (CI,"VEN-I I")),"^",1 5),1,5) I  VZ="" S CH MFQUE=10,C HMMDP=CHMM DP_": PL-Z IP MISSING " G END S  VC=$O(^CHM SMSA("ZIP" ,VZ,0)) G  HOSPCE:'VC  G HOSPCE: '$D(^CHMSM SA(VC,4,0) ) S PHPDAT =$O(^CHMSM SA(VC,4,"B ",CHADOS), -1) G HOSP CE:'PHPDAT  S PHPI=$O (^CHMSMSA( VC,4,"B",P HPDAT,0))  G HOSPCE:' PHPI G HOS PCE:'$D(^C HMSMSA(VC, 4,PHPI,0))  S PHPF=$O (^CHMDIC(7 41013.13," B",$P(@(GL PAY_"CI,K2 ,NM,0)")," ^",1),0))  G HOSPCE:' PHPF S FDH D=$P(^CHMD IC(741013. 13,PHPF,0) ,"^",2) S  CHMPF=$P(^ CHMSMSA(VC ,4,PHPI,0) ,"^",FDHD)  G HOSPCE: +CHMPF=0 S  CMAC(NM)= CHMPF S $P (@(GLPAY_" CI,""RULE- PROC"",NM, 0)"),"^",9 )=5 G ENDH OSPCE  ; D EV006421 i ncorporati ng a new p ayment req uirement f or hospice  payment N  IEN,NM1,C BSA,CBSAIE N,CBSAIEN1 ,CBSANM,CB SANM1,CBSA WC,CBSANWA ,CBSAWG,CB SAENT,CBSA ENT1             ;;DE V006421 ne w variable s added fo r this sec tion G ASC :CHADOS<29 70801 ;;th is code fr om here to  END is ne w for DEV0 06421 - DR W - 06/15/ 12 G ASC:$ P(RECC,"^" ,16)'=5 ;; 5 indicate s outpatie nt  S FLG= 0 I $P(REC C,"^",2)=" " G NEXT I  $P(^CHMDI C(741002.1 1,$P(RECC, "^",2),0), "^",1)="HP C" S FLG=F LG+1 ;;hos pice facil ity typeNE XT  ; in o rder to av oid subscr ipt error  if facilit y type not  defined   S CHMSP=$P (@(GLPAY_" CI,K2,NM,0 )"),"^"),C HMSPC=$P(^ CHMSERV(CH MSP,0),"^" ,1) ;;CHMS P contains  pointer t o CHMSERV  and CHMSPC  is the se rvice code  returned  from CHMSE RV  G:(CHM SPC'="X700 0")&(CHMSP C'="X7001" )&(CHMSPC' ="00.00")& (CHMSPC'=" 00.99") AS C ; CPE VE NDOR STREA MLINING Re place Prov ider zip w ith PL-ZIP  gef ;I '$ D(^CHMVEN( VI,2)) S C HMFQUE=10, CHMMDP=CHM MDP_": VEN DOR ZIP MI SSING" G E ND ;S VZ=$ E($P(^CHMV EN(VI,2)," ^",5),1,5)   ;I VZ=""  S CHMFQUE =10,CHMMDP =CHMMDP_":  VENDOR ZI P MISSING"  G END  S  VZ=$E($P($ G(^CHMPAY( CI,"VEN-II ")),"^",15 ),1,5) I V Z="" S CHM FQUE=10,CH MMDP=CHMMD P_": PL-ZI P MISSING"  G END S I EN=$O(^CHM DIC(741006 .03,"B",VZ ,0)) ;;fin d the IEN  for the CB SA crosswa lk based o n zip ; ;; DEV022592  JSE 3/3/15  WAGE RATE  NEVER SET  CORRECTLY  B/C NM1 W AS NEVER S ET TO THE  CORRECT DI C LOOKUP   ;; COMMENT  OUT HOW N M1 WAS ORI GINALY SET  & THE ATT EMPTED FIX  FROM DEV0 21956 (BEL OW) ;S NM1 =$O(^CHMDI C(741006.0 3,IEN,1,CH ADOS),-1)  ;; ORIG CO DE INCORRE CT, CAUSIN G SUBSCRIP T ERRS ;CH ECKDT; IF  DOS IS NOT  CHECKED,  THE IEN AB OVE MAY NO T BE THE C ORRECT CBS A ;; DEV02 1956 DRW 1 1/06/2014   ;S EFFDT= $P(^CHMDIC (741006.03 ,IEN,1,NM1 ,0),"^",1)  ;; DEV021 956 DRW 11 /06/2014   ;I CHADOS< EFFDT S NM 1=NM1-1 G  CHECKDT ;; LOOP THROU GH UNTIL D OS IS NO L ONGER LESS  THAN EFFE CTIVE DATE   ; ;;DEV0 22592 JSE  - NEW LOGI C(BELOW) C ORRECTLY S ETS NM1. T HIS LOGIC  REPLACE TH E LOGIC AB OVE. I $D( ^CHMDIC(74 1006.03,IE N,1,"B",CH ADOS)) S C HADOS2=CHA DOS         ;; DEV022 592 JSE -  IF DOS HAS  AN ENTRY  USE DOS DA TE E  S CH ADOS2=$O(^ CHMDIC(741 006.03,IEN ,1,"B",CHA DOS),-1) ; ; DEV02259 2 JSE - IF  NO DOS EN TRY, USE D ATE B4 DOS  I CHADOS2 ="" S CHAD OS2=$O(^CH MDIC(74100 6.03,IEN,1 ,"B",0)) ; ; DEV02259 2 JSE - IF  DOS IS B4  THE 1ST E NT, SET NM 1=1ST ENT  S NM1=$O(^ CHMDIC(741 006.03,IEN ,1,"B",CHA DOS2,""))  ;; DEV0225 92 JSE - S ET NM1 TO  ENTRY# 4 S ELECTED DA TE ; S CBS A=$P(^CHMD IC(741006. 03,IEN,1,N M1,0),"^", 5) ;;once  the CBSA i s found, u se the CBS A to find  the wage i ndex on gl obal ^CHMD IC(741043  S CBSAIEN= $O(^CHMDIC (741043,"B ",CBSA,0))  ;S CBSANM =$O(^CHMDI C(741043,C BSAIEN,1," B",CHADOS) ,-1) ;; Fi nd the las t entry cl ose to the  DOS (reve rse order) ) I $D(^CH MDIC(74104 3,CBSAIEN, 1,"B",CHAD OS)) S CBS ANM=CHADOS         ;;  DEV021956  DRW - ADD ED IF/ELSE  FOR EFFEC TIVE DATE  E  S CBSAN M=$O(^CHMD IC(741043, CBSAIEN,1, "B",CHADOS ),-1) ;; D EV021956 F ind last e ntry close st to DOS  (rev. orde r)) I CBSA NM="" S CB SANM=$O(^C HMDIC(7410 43,CBSAIEN ,1,"B",CHA DOS)) S CB SAENT=$O(^ CHMDIC(741 043,CBSAIE N,1,"B",CB SANM,0)) ; ;find the  physical l ocation of  the entry  number S  CBSAWG=$P( ^CHMDIC(74 1043,CBSAI EN,1,CBSAE NT,0),"^", 6) ;;wage  index rate  for the h ospice cla im ;;once  the CBSAWG  is found,  use the f ormula rat e associat ed with th e service  code in ;; global ^CH MDIC(74104 5 to deter mine the h ospice per  diem rate  S CBSAIEN 1=$O(^CHMD IC(741045, "B",CHMSPC ,0)) ;S CB SANM1=$O(^ CHMDIC(741 045,CBSAIE N1,1,"B",C HADOS),-1)  I $D(^CHM DIC(741045 ,CBSAIEN1, 1,"B",CHAD OS)) S CBS ANM1=CHADO S      ;;D EV021956 D RW-ADDED I F/ELSE FOR  EFFECTIVE  DATE E  S  CBSANM1=$ O(^CHMDIC( 741045,CBS AIEN1,1,"B ",CHADOS), -1) I CBSA NM1="" S C BSANM1=$O( ^CHMDIC(74 1045,CBSAI EN1,1,"B", CHADOS)) S  CBSAENT1= $O(^CHMDIC (741045,CB SAIEN1,1," B",CBSANM1 ,0)) ;;fin d the entr y location  of date S  CBSAWC=$P (^CHMDIC(7 41045,CBSA IEN1,1,CBS AENT1,0)," ^",4) ;;fi nd the wag e componen t S CBSANW A=$P(^CHMD IC(741045, CBSAIEN1,1 ,CBSAENT1, 0),"^",5)  ;;find the  non-weigh ted amount  S HOSPAMT =(CBSAWC*C BSAWG)+CBS ANWA                           ; ;multiply  wage compo nent by th e CBSA ind ex + non-w eighted am t I CHMSPC ="X7001" D  . S HOSPA MT=HOSPAMT /24 ;;divi de by the  number of  hours in o ne day to  get daily  rate S HOS PAMT=$FN(H OSPAMT,"", 2) ;;the $ FN functio n rounds &  sets to t wo decimal  places S  CHMPF=+HOS PAMT S CMA C(NM)=CHMP F G ENDASC  S CHMSP=$ P(@(GLPAY_ "CI,K2,NM, 0)"),"^"), CHMSPC=$P( ^CHMSERV(C HMSP,0),"^ ",1) ; Sub script err or 9/30/05  mlr G CMA C:$P(RECC, "^",2)=""  G CMAC:$P( ^CHMDIC(74 1002.11,$P (RECC,"^", 2),0),"^", 1)'="ASC"  ; CPE VEND OR STREAML INING Repl ace Provid er zip wit h PL-ZIP g ef ;I '$D( ^CHMVEN(VI ,2)) S CHM FQUE=10,CH MMDP=CHMMD P_": VENDO R ZIP MISS ING" G END  G CMAC:$P (^CHMVEN(V I,1),"^",7 )="" S CHF AC=$P(^(1) ,"^",7) G  CMAC:($P(^ CHMDIC(741 002.11,CHF AC,0),"^", 1)'="ASF") &($P(^CHMD IC(741002. 11,CHFAC,0 ),"^",1)'= "ASH") G A SC1:'$D(^C HMAGP("B", CHMSPC)) ;  CPE VENDO R STREAMLI NING Repla ce Provide r zip with  PL-ZIP ge f ;S VZ=$E ($P(^CHMVE N(VI,2),"^ ",5),1,5)  ;I VZ="" S  CHMFQUE=1 0,CHMMDP=C HMMDP_": V ENDOR ZIP  MISSING" G  END S VZ= $E($P($G(^ CHMPAY(CI, "VEN-II")) ,"^",15),1 ,5) I VZ=" " S CHMFQU E=10,CHMMD P=CHMMDP_" : PL-ZIP M ISSING" G  END S VC=$ O(^CHMDIC( 741002.82, "B",VZ,0))  G CMAC:'V C S CHLDT= $O(^CHMDIC (741002.82 ,VC,1,9999 999),-1) G  CMAC:'CHL DT G CMAC: '$D(^CHMDI C(741002.8 2,VC,1,CHL DT,0)) S C HMSA=$P(^( 0),"^",2)  F JJ=$L(CH MSA):1:3 S  CHMSA="0" _CHMSA S C HMGPN=0,CH MGPN=$O(^C HMAGP("B", CHMSPC,CHM GPN))  I ' CHMGPN I $ P(^CHMDIC( 741002.11, CHFAC,0)," ^",1)="ASF " G ASC2 ; nsd I18439 016FY18 -  dpt  I 'CH MGPN I $P( ^CHMDIC(74 1002.11,CH FAC,0),"^" ,1)'="ASF"  G CMAC ;: 'CHMGPN ;n sd I184390 16FY18 - d pt  ;I '$D (^CHMAGP(C HMGPN,1,(C HADOS+1)))  I $P(^CHM DIC(741002 .11,CHFAC, 0),"^",1)= "ASF" G AS C2  ;I '$D (^CHMAGP(C HMGPN,1,(C HADOS+1)))  I $P(^CHM DIC(741002 .11,CHFAC, 0),"^",1)' ="ASF" G C MAC  ;I $D (^CHMAGP(C HMGPN,1,(C HADOS+1)))  S CHGRDT= $O(^CHMAGP (CHMGPN,1, (CHADOS+1) ),-1) I CH GRDT="" D  ; .I $P(^C HMDIC(7410 02.11,CHFA C,0),"^",1 )="ASF" G  ASC2  ; .I  $P(^CHMDI C(741002.1 1,CHFAC,0) ,"^",1)'=" ASF" G CMA C ;nsd I18 439016FY18  - dpt S C HGRDT=0,CH GRDT=$O(^C HMAGP(CHMG PN,1,CHGRD T)) S CHBE G=$P(^CHMA GP(CHMGPN, 1,CHGRDT,0 ),"^",1) ; nsd I18439 016FY18 -  dpt ;S CHG RDT=$O(^CH MAGP(CHMGP N,1,999999 9),-1)  I  CHADOS<CHB EG  I $P(^ CHMDIC(741 002.11,CHF AC,0),"^", 1)="ASF" G  ASC2  ;;n sd I184390 16FY18 - d pt DEF0167 63 DPT 3/2 8/11 DEV00 9248-03 I  CHADOS<CHB EG  I $P(^ CHMDIC(741 002.11,CHF AC,0),"^", 1)'="ASF"  G CMAC ;TE ST DPT G C MAC:'$D(^C HMAGP(CHMG PN,1,CHGRD T,0)) S CH GRP=+$P(^( 0),"^",2)  S CHGRP=+$ P(^CHMAGP( CHMGPN,1,C HGRDT,0)," ^",2) ;DPT  8/18/10 B UG009248-0 3 S CHLEDT =+$P(^CHMA GP(CHMGPN, 1,CHGRDT,0 ),"^",3) ; BUG016763- 03-01 DPT  8/18/10 I  CHLEDT'=0, CHADOS>CHL EDT I $P(^ CHMDIC(741 002.11,CHF AC,0),"^", 1)="ASF"   G ASC2   ; ;nsd I1843 9016FY18 -  dpt I CHL EDT'=0,CHA DOS>CHLEDT  I $P(^CHM DIC(741002 .11,CHFAC, 0),"^",1)= "ASF" G CM AC ;;nsd I 18439016FY 18 - dpt S  CHMMPN=0, CHMMPN=$O( ^CHMART("B ",CHMSA,CH MMPN)) G C MAC:'CHMMP N S CHMSDT =$O(^CHMAR T(CHMMPN,1 ,(CHADOS+1 )),-1) G A SC1:'CHMSD T ; DPT 3/ 28/11 BUG0 09248-05 G  CMAC:'$D( ^CHMART(CH MMPN,1,CHM SDT,100,CH GRP,0)) S  CHMPF=+$P( ^(0),"^",1 ) G CMAC:+ CHMPF=0 S  CHMSEDT=+$ P(^CHMART( CHMMPN,1,C HMSDT,0)," ^",2) ;DPT  8/18/10 I  CHMSEDT'= 0,CHADOS>C HMSEDT  I  $P(^CHMDIC (741002.11 ,CHFAC,0), "^",1)="AS F" G ASC2   ; ;nsd I1 8439016FY1 8 - dpt DP T 3/28/11  DEV009248- 03 I CHMSE DT'=0,CHAD OS>CHMSEDT   I $P(^CH MDIC(74100 2.11,CHFAC ,0),"^",1) '="ASF" G  CMAC  ;nsd  I18439016 FY18 - dpt  S $P(@(GL PAY_"CI,"" RULE-PROC" ",NM,0)"), "^",9)=3 ; I WRT=1 S  $P(@(GLPAY _"CI,""RUL E-PROC"",N M,0)"),"^" ,9)=3 ;DEV 004651 2/1 1/14 EW TE ST FOR WRI TE FLAG S  CMAC(NM)=C HMPF S $P( @(GLPAY_"C I,""COMMON "")"),"^", 16)=9 ;I W RT=1 S $P( @(GLPAY_"C I,""COMMON "")"),"^", 16)=9 ;DEV 004651 2/1 1/14 EW TE ST FOR WRI TE FLAG G  ENDASC1 S  CHMPF=+$P( @(GLPAY_"C I,K2,NM,0) "),"^",2), CMAC(NM)=C HMPF S $P( @(GLPAY_"C I,""COMMON "")"),"^", 16)=9 ;I W RT=1 S $P( @(GLPAY_"C I,""COMMON "")"),"^", 16)=9 ;DEV 004651 2/1 1/14 EW TE ST FOR WRI TE FLAG G  ENDASC2 S  CHMPF=0,CM AC(NM)=0,R EA=196,$P( @(GLPAY_"C I,""RULE-P ROC"",NM,0 )"),"^",2) =REA G END   ;DEF0167 63 DPTCMAC  I VI="" S  CHMFQUE=1 0,CHMMDP=C HMMDP_": V ENDOR ID M ISSING" G  END G PF:' $D(^CHMVEN (VI,41)) S  CHCLS=""  D  G PF:CH CLS="" .S  CMJ=$O(^CH MVEN(VI,41 ,9999999), -1) Q:'CMJ  .S CHCLS= $P(^CHMVEN (VI,41,CMJ ,0),"^",3)  G PF:"1^2 ^3"'[CHCLS  S CHMSP=$ P(@(GLPAY_ "CI,K2,NM, 0)"),"^")  S CHMSPC=$ P(^CHMSERV (CHMSP,0), "^",1) ;CP E VENDOR S TREAMLININ G replace  Provider Z ip w/ PL-Z IP gef ;I  '$D(^CHMVE N(VI,2)) S  VZ="" G C 0 ;S VZ=$E ($P(^CHMVE N(VI,2),"^ ",5),1,5)  S VZ=$E($P ($G(^CHMPA Y(CI,"VEN- II")),"^", 15),1,5)C0  I VZ="" S  CHMFQUE=1 0,CHMMDP=C HMMDP_": P L-ZIP MISS ING" G END  S VC=$O(^ CHMDIC(741 002.4,"B", VZ,0)) G P F:VC="" S  CHLDT=9999 999-CHADOS -1C1 S CHL DT=$O(^CHM DIC(741002 .4,VC,1,CH LDT)) G PF :CHLDT'?7N  G PF:'$D( ^CHMDIC(74 1002.4,VC, 1,CHLDT,0) ) S CHLOC= $P(^(0),"^ ",2) S CHM SPN=$O(^CH MCPF("B",C HMSPC,0))  G PF:'CHMS PN S CHX=0 C2 S CHX=$ O(^CHMCPF( CHMSPN,CHX )) G C1:'C HX G:CHX+8 >1000 C1 G :CHX+8>CHL OC C22 G C 2C22 S CHC MDT=999999 9-CHADOS-1 C3 S CHCMD T=$O(^CHMC PF(CHMSPN, CHX,CHCMDT )) G PF:CH CMDT'?7N G  PF:'$D(^C HMCPF(CHMS PN,CHX,CHC MDT,0)) S  CHLNM=CHLO C#8 S:CHLO C#8=0 CHLN M=8 S CHMR EC=$P(^CHM CPF(CHMSPN ,CHX,CHCMD T,0),"^",2 ) S CHPNM= $P(CHMREC, ",",CHLNM)  D:CHADOS> 3070131 GE TCLP   ; J EH 2/1/07  CUT-OVER D ATE (2/1/0 7) TO NEW  CMAC FORMA T S CHMPF= $P(CHPNM," ;",CHCLS), MOD="" I K 2="OPT-PRO C" D       ;JEH 2/13/ 09 TT ENC0 04843 .S M OD=$$GTMOD ^CHFBC2A(C I,K2,NM,CH MSPC) ;JEH  2/13/09 T T ENC00484 3 ADDED SU BROUTINE ; S:K2="OPT- PROC" MOD= $P(@(GLPAY _"CI,K2,NM ,0)"),"^", 4) ;JEH 2/ 13/09 TT E NC004843 S :K2="DEN-P ROC" MOD=$ P(@(GLPAY_ "CI,K2,NM, 0)"),"^",6 ) D:MOD'=" " .Q:CHADO S<2970701  .Q:('$D(^C HMDIC(7410 02.98,"B", MOD)))&('$ D(^CHMDIC( 741002.99, "B",MOD)))  .S FILEPT =$S($D(^CH MDIC(74100 2.98,"B",M OD)):"7410 02.98",$D( ^CHMDIC(74 1002.99,"B ",MOD)):"7 41002.99", 1:"") .Q:F ILEPT="" . I '$D(^CHM CPF(CHMSPN ,CHX,CHCMD T,1)) D  Q         ;P RO/TECH .. S REA="",P ERC="" ..S  MODI=$O(^ CHMDIC(FIL EPT,"B",MO D,0)) ..I  MODI'="" S :$D(^CHMDI C(FILEPT,M ODI,0)) RE A=$P(^(0), "^",2),PER C=$P(^(0), "^",3) ..S  CHMPF=CHM PF*PERC .. S X1=CI D  PROGTYP^CH FCD001 ..S  $P(@(GLPA Y_"CI,K1,N M,0)"),"^" ,2)=REA .. ;I WRT=1 S  $P(@(GLPA Y_"CI,K1,N M,0)"),"^" ,2)=REA ;D EV004651 2 /11/14 EW  TEST FOR W RITE FLAG  ..;S $P(@( GLPAY_"CI, ""RULE-PRO C"",NM,0)" ),U,2)=REA  .I CHCLS= 2&(CHADOS< 3070201) D   Q     ;J EH 2/11/07  ADDED 'CH ADOS<30702 01' DUE TO  NEW FORMA T AND CUTO VER DATE . .S PERC="" ,REA="" .. S MODI=$O( ^CHMDIC(FI LEPT,"B",M OD,0)) ..I  MODI'=""  S:$D(^CHMD IC(FILEPT, MODI,0)) R EA=$P(^(0) ,"^",2),PE RC=$P(^(0) ,"^",3) .. S CHMPF=CH MPF*PERC . .S X1=CI D  PROGTYP^C HFCD001 .. S $P(@(GLP AY_"CI,K1, NM,0)"),"^ ",2)=REA . .;I WRT=1  S $P(@(GLP AY_"CI,K1, NM,0)"),"^ ",2)=REA ; DEV004651  2/11/14 EW  TEST FOR  WRITE FLAG  ..;S $P(@ (GLPAY_"CI ,""RULE-PR OC"",NM,0) "),U,2)=RE A  .S CHMR EC1=$P(^CH MCPF(CHMSP N,CHX,CHCM DT,1),"^", 2) .S CHPN M1=$P(CHMR EC1,",",CH LNM) .;S:F ILEPT=7410 02.98 PT1= CHCLS ;CHA MPVA PROF  COMPONENT  MODIFIERS  .;S:FILEPT =741002.99  PT1=$S(CH CLS=1:2,CH CLS=3:4) ; CHAMPVA TE CH COMPONE NT MODIFIE RS .I FILE PT=741002. 98 D                    ;CHAMPVA  PROF. COM PONENT MOD FIERS ;JEH  2/11/07 A DDED FOR N EW FORMAT  AND CUTOVE R DATE ..I  CHADOS<30 70201 D .. .S PT1=CHC LS ..E  D  ...S PT1=$ S(CHCLS=1: 1,CHCLS=2: 1,CHCLS=3: 3,CHCLS=4: 3) .I FILE PT=741002. 99 D                    ;CHAMPVA  TECH COMP ONENT MODI FIERS ;JEH  2/11/07 A DDED FOR N EW FORMAT  AND CUTOVE R DATE ..I  CHADOS<30 70201 D .. .S PT1=$S( CHCLS=1:2, CHCLS=3:4)  ..E  D .. .S PT1=$S( CHCLS=1:2, CHCLS=2:2, CHCLS=3:4, CHCLS=4:4)  .S CHMPF= $P(CHPNM1, ";",PT1) . S REA="" . S MODI=$O( ^CHMDIC(FI LEPT,"B",M OD,0)) .I  MODI'="" S :$D(^CHMDI C(FILEPT,M ODI,0)) RE A=$P(^(0), "^",2) .S  X1=CI D PR OGTYP^CHFC D001 .S $P (@(GLPAY_" CI,K1,NM,0 )"),"^",2) =REA .;I W RT=1 S $P( @(GLPAY_"C I,K1,NM,0) "),"^",2)= REA ;DEV00 4651 2/11/ 14 EW TEST  FOR WRITE  FLAG .;S  $P(@(GLPAY _"CI,""RUL E-PROC"",N M,0)"),U,2 )=REA  G P F:+CHMPF=0  S $P(@(GL PAY_"CI,"" RULE-PROC" ",NM,0)"), "^",9)=1 ; I WRT=1 S  $P(@(GLPAY _"CI,""RUL E-PROC"",N M,0)"),"^" ,9)=1 ;DEV 004651 2/1 1/14 EW TE ST FOR WRI TE FLAG S  CMAC(NM)=C HMPF G END PF S CHMPF =0,CHMDOS= $P(REC0,"^ ",8),CHMRD T=9999999- CHMDOS,CHM RSD=CHMRDT -1 ; Y2K f ix ;S YR=$ E(CHMDOS,2 ,3) I $E(Y R,2)="0" S  YR=$E(YR, 1) ;S FN=" 741012."_Y R S YR=$E( CHMDOS,1,3 ) S FN=$$F NSET^CHFBC 2A(CHMDOS)  ; S CHMSP C=$P(@(GLP AY_"CI,K2, NM,0)"),"^ ") S VI=$P (REC0,"^", 3) I VI=""  S CHMFQUE =10,CHMMDP =CHMMDP_":  VENDOR ID  MISSING"  G END ;CPE  VENDOR ST REAMLINING  replace P rovider Zi p w/ PL-ZI P gef ;I ' $D(^CHMVEN (VI,2)) S  VZ="" G A0  ;S VZ=$E( $P(^CHMVEN (VI,2),"^" ,5),1,5) S  VZ=$E($P( $G(^CHMPAY (CI,"VEN-I I")),"^",1 5),1,5)A0  I VZ="" S  CHMFQUE=10 ,CHMMDP=CH MMDP_": PL -ZIP MISSI NG" G END  S VST=$P(^ CHMVEN(VI, 2),"^",4)  ;CPE001-11 9 CFS - Fi x undefine d error. I  VST="" S  CHMFQUE=10 ,CHMMDP=CH MMDP_": VE NDOR STATE  MISSING "  G END S V C=$O(^CHMS MSA("ZIP", VZ,VST,0))  I VC="" S  CHMFQUE=1 0,CHMMDP=C HMMDP_": P L-ZIP UNKN OWN OR INC OMPATIBLE  WITH STATE " G END S  CHMSPN=$O( ^CHMSPF(FN ,"B",CHMSP C,0)) G:CH MSPN="" EN D I $D(^CH MSPF(FN,CH MSPN,"DEL" )),$P(^("D EL"),"^",1 )=1 G END  S CHSMDT=$ O(^CHMSMSA (VST,1,VC, 3,CHMRSD))  I CHSMDT' ?1N.N D GS TSM G A1 S  CHMSNUM=$ P(^CHMSMSA (VST,1,VC, 3,CHSMDT,0 ),"^",2) I  (CHMSNUM= 0)!(CHMSNU M="") D GS TSM G A1 S  PF=$S(((C HMSNUM'>20 )&(CHMSNUM >0)):1,((C HMSNUM'>40 )&(CHMSNUM >20)):2,(( CHMSNUM'>6 0)&(CHMSNU M>40)):3,( (CHMSNUM'> 80)&(CHMSN UM>60)):4, ((CHMSNUM' >100)&(CHM SNUM>80)): 5,1:6) I P F=6 D GSTS M G A1 I C HMSNUM<21, $D(^CHMSPF (FN,CHMSPN ,PF)) S:$D (^CHMSPF(F N,CHMSPN,P F)) CHMPFD =$P(^CHMSP F(FN,CHMSP N,PF),",", CHMSNUM) I  CHMPFD'=" " S CHMPF= +$P(CHMPFD ,";",1) E   I $D(^CHM SPF(FN,CHM SPN,PF)) S :$D(^CHMSP F(FN,CHMSP N,PF)) CHM PFD=$P(^CH MSPF(FN,CH MSPN,PF)," ,",(CHMSNU M#(20*($S( PF=1:1,PF= 2:1,PF=3:2 ,PF=4:3,PF =5:4,1:1)) ))) I CHMP FD'="" S C HMPF=+$P(C HMPFD,";", 1) I CHMPF =0 D GSTSM :YR>293 G  END:YR<294  G END:CHM PF=0 S MOD ="" I K2=" OPT-PROC"  D      ;JE H 2/13/09  TT ENC0048 43 .S TMPS PC=$P(^CHM SERV(CHMSP C,0),"^",1 ) ;GET COD E .S MOD=$ $GTMOD^CHF BC2A(CI,K2 ,NM,TMPSPC ) ;JEH 2/1 3/09 TT EN C004843 AD DED SUBROU TINE ;S:K2 ="OPT-PROC " MOD=$P(@ (GLPAY_"CI ,K2,NM,0)" ),"^",4) ; JEH 2/13/0 9 TT ENC00 4843 S:K2= "DEN-PROC"  MOD=$P(@( GLPAY_"CI, K2,NM,0)") ,"^",6) D: MOD'="" .Q :CHADOS<29 70701 .Q:( '$D(^CHMDI C(741002.9 8,"B",MOD) ))&('$D(^C HMDIC(7410 02.99,"B", MOD))) .S  FILEPT=$S( $D(^CHMDIC (741002.98 ,"B",MOD)) :"741002.9 8",$D(^CHM DIC(741002 .99,"B",MO D)):"74100 2.99",1:"" ) .Q:FILEP T="" .S PE RC="",REA= "" .S MODI =$O(^CHMDI C(FILEPT," B",MOD,0))  .I MODI'= "" S:$D(^C HMDIC(FILE PT,MODI,0) ) REA=$P(^ (0),"^",2) ,PERC=$P(^ (0),"^",3)  .S CHMPF= CHMPF*PERC  .S X1=CI  D PROGTYP^ CHFCD001 . S $P(@(GLP AY_"CI,K1, NM,0)"),"^ ",2)=REA . ;I WRT=1 S  $P(@(GLPA Y_"CI,K1,N M,0)"),"^" ,2)=REA ;D EV004651 2 /11/14 EW  TEST FOR W RITE FLAG  .;S $P(@(G LPAY_"CI," "RULE-PROC "",NM,0)") ,U,2)=REAA 1 ;I WRT=1  S $P(@(GL PAY_"CI,"" RULE-PROC" ",NM,0)"), "^",9)=2 ; DEV004651  2/11/14 EW  TEST FOR  WRITE FLAG  S $P(@(GL PAY_"CI,"" RULE-PROC" ",NM,0)"), "^",9)=2 S  CMAC(NM)= CHMPFEND I  (K2="DME- SUPPLY")!( K2="OPT-PR OC") D .Q: $P(@(GLPAY _"CI,""RUL E-PROC"",N M,0)"),"^" ,9)=196 ;D EF016763 D PT .Q:$P(@ (GLPAY_"CI ,K2,NM,0)" ),"^",5)=" " .S CHMPF =$P(^(0)," ^",5),CMAC (NM)=CHMPF  .S $P(@(G LPAY_"CI," "RULE-PROC "",NM,0)") ,"^",9)=4  .;I WRT=1  S $P(@(GLP AY_"CI,""R ULE-PROC"" ,NM,0)")," ^",9)=4 ;D EV004651 2 /11/14 EW  TEST FOR W RITE FLAG  .S ALLOW=1  I K2="DEN -PROC" D . Q:$P(@(GLP AY_"CI,K2, NM,0)"),"^ ",7)="" .S  CHMPF=$P( ^(0),"^",7 ),CMAC(NM) =CHMPF .S  $P(@(GLPAY _"CI,""RUL E-PROC"",N M,0)"),"^" ,9)=4 .;I  WRT=1 S $P (@(GLPAY_" CI,""RULE- PROC"",NM, 0)"),"^",9 )=4 ;DEV00 4651 2/11/ 14 EW TEST  FOR WRITE  FLAG .S A LLOW=1 K C HMPFD,CHMS PN,CHMSNUM ,CHSMDT,VS T,VC,VI,VZ ,CHMSP,CHM SPC,CHLDT  K CHMSA,CH MGPN,CHGRD T,CHMMPN,C HMSDT,CHGR P,CHFAC,HO SPAMT QGST SM I VST>4 0 I $D(^CH MSPF(FN,CH MSPN,0)) S :$D(^CHMSP F(FN,CHMSP N,103)) CH MPFD=$P(^C HMSPF(FN,C HMSPN,103) ,",",VST-4 0) I $G(CH MPFD)'=""  S CHMPF=+$ P(CHMPFD," ;",1) Q    ;SKD 1-10- 07; I CHMP FD'="" I ( VST>20)&(V ST'>40) I  $D(^CHMSPF (FN,CHMSPN ,0)) S:$D( ^CHMSPF(FN ,CHMSPN,10 2)) CHMPFD =$P(^CHMSP F(FN,CHMSP N,102),"," ,VST-20) I  $G(CHMPFD )'="" S CH MPF=+$P(CH MPFD,";",1 ) Q   ;SKD  1-10-07;  I CHMPFD'= "" I (VST> 0)&(VST'>2 0) I $D(^C HMSPF(FN,C HMSPN,0))  S:$D(^CHMS PF(FN,CHMS PN,101)) C HMPFD=$P(^ CHMSPF(FN, CHMSPN,101 ),",",VST)  I $G(CHMP FD)'="" S  CHMPF=+$P( CHMPFD,";" ,1) Q    ; SKD 1-10-0 7; I CHMPF D'="" QGET CLP ;DETER MINE CMAC  RATE POSIT ION Q:$D(^ CHMSERV(CH MSP,4)) ;Q UIT IF ANE THESIA COD E ; JEH 12 /5/06 S CH MFAC=0 ; S et default  to Non-fa cility S C HMPOS=99 ;  Set defau lt to Othe r location  S PTR=""   ;AEB 4/17 /2007  S:$ D(@(GLPAY_ "CI,""COMM ON"")")) I =$P(@(GLPA Y_"CI,""CO MMON"")"), "^",2) ;I  I I $D(^CH MDIC(74100 2.11,I,0))  S PTR=$P( ^(0),"^",5 ) ;JEH 3/2 5/08 ;I PT R I $D(^IB E(353.1,PT R,0)) S CH MFAC=$P(^( 0),"^",4)  ;GET FACIL ITY TYPE ; JEH 3/25/0 8 I I I $D (^CHMDIC(7 41002.11,I ,0)) S CHM FAC=$P(^(0 ),"^",7) ; JEH 3/25/0 8 S CHCLS= CHCLS+CHMF AC QFNSET( FMDT) ;Set s the corr ect FN for  prevailin g fee glob al (CHMSPF ) ; FMDT m ust be a f ileman dat e (2990101 ) or at le ast the ;  first thre e position s of the f ileman dt  (299) ; Y2 K - This w as added t o make glo bal Y2K co mpliant (F N was 7410 12.99 ; an d now is 7 41012.299) . Trailing  zeros wil l be trunc ated in  ;  order to  be compati able with  Fileman. ;   N X,Y S  Y="" I $L( FMDT)>2 D  .S X=$E(FM DT,1,3) .I  $E(X,3)=0  S X=$E(X, 1,2) D ..I  $E(X,2)=0  S X=$E(X, 1) .S Y="7 41012."_X  Q YGTMOD(G CI,GK2,GNM ,GCHMSPC)  ;SUBROUTIN E TO DETER MINE/GET M ODIFIERS F OR OUTPATI ENT CLAIMS  ;JEH 4/13 /10 ENC004 843 ;GCI =  CLAIM POI NTER ;GK2  = GLOBAL N ODE INDICA TOR - "OPT -PROC" ;GN M = J VALU E FROM PAY  FILE N MO D,TOB,POS, TOC,CHMREC ,CHPNM,CHM REC1,CHPNM 1 S MOD=""  S MOD=$P( @(GLPAY_"G CI,GK2,GNM ,0)"),"^", 4) Q:'$D(^ CHMCPF("B" ,GCHMSPC))  MOD   ;QU IT IF CODE  NOT IN CM AC GLOBAL  Q:MOD=4!(M OD=83) MOD   ;4=26/83 =TC S TOC= "" S TOC=$ P(@(GLPAY_ "GCI,0)"), "^",7) ;TY PE OF CLAI M 2=OUTPAT IENT Q:TOC '=2 MOD Q: CHCMDT=""  MOD                           ;  RFE 6/30/1 6 DEV02563 3  I (GCHM SPC>=70000 )&(GCHMSPC <=90000) {     S TOB= ""   ;BILL  TYPE BILL  (013x-HOS P OUTPATIE NT, 014x-H OSP OTHER  PART B)     S:$D(@(GL PAY_"GCI,7 )")) TOB=$ P(@(GLPAY_ "GCI,7)"), "^",6)     S POS=0 S  POS=$P(@(G LPAY_"GCI, ""COMMON"" )"),"^",2)  ;PLACE OF  SERVICE     I TOB'=" " {         I ("12,13 ,14,22,23, 83"[$E(TOB ,1,2))&(PO S=2) {       ;BILL CO DE TYPE 01 3x-Hospita l Outpatie nt/014x-Ho spital Oth er Part B              I $D(^CHM CPF(CHMSPN ,CHX,CHCMD T,0)) {                  S CHMRE C=$P(^CHMC PF(CHMSPN, CHX,CHCMDT ,0),"^",2)  ;TECH                  S CHPNM= $P(CHMREC, ",",CHLNM)                  I $P (CHPNM,";" ,4)'=""&($ P(CHPNM,"; ",4)>0) S  MOD=83 ;83 =TC             }         }    }     I (TOB =""&(POS=2 ))!(POS=86 ) {   ;2-O P,86-IPP         I $D (^CHMCPF(C HMSPN,CHX, CHCMDT,1))  {             S CHMR EC1=$P(^CH MCPF(CHMSP N,CHX,CHCM DT,1),"^", 2) ;PRO             S  CHPNM1=$P (CHMREC1," ,",CHLNM)              I $P(CHPN M1,";",3)' =""&($P(CH PNM1,";",3 )>0) S MOD =4 ;4=26         }     } } Q MOD
  11  
  12  
  13  
  14   Difference s
  15  
  16   See  highl ighted inf o above.
  17  
  18  
  19   Passed XIN DEX?  (Y /  N):  
  20  
  21  
  22  
  23   XINDEX Err ors are ex isting cod e caused b y using cu rly bracke ts “{}” in stead of u sing Do do t structur e.
  24   Compiled l ist of Err ors and Wa rnings                Mar 28, 20 18@07:34:2 4 page 1
  25  
  26   CHFBC2A  *  *  385 Li nes,  2279 1 Bytes, C hecksum: B 242843359
  27            I  (GCHMSPC> =70000)&(G CHMSPC<=90 000) {
  28      GTMOD+1 2     F -  UNDEFINED  COMMAND (r est of lin e not chec ked).
  29                I TOB'=" " {
  30      GTMOD+1 6     F -  UNDEFINED  COMMAND (r est of lin e not chec ked).
  31                    I (" 12,13,14,2 2,23,83"[$ E(TOB,1,2) )&(POS=2)  {      ;BI LL CODE TY
  32              PE  013x-H ospital Ou tpatient/0 14x-Hospit al Other P art B
  33      GTMOD+1 7     F -  UNDEFINED  COMMAND (r est of lin e not chec ked).
  34                         I $D(^CHMC PF(CHMSPN, CHX,CHCMDT ,0)) {
  35      GTMOD+1 8     F -  UNDEFINED  COMMAND (r est of lin e not chec ked).
  36                         }
  37      GTMOD+2 2     F -  UNDEFINED  COMMAND (r est of lin e not chec ked).
  38                    }
  39      GTMOD+2 3     F -  UNDEFINED  COMMAND (r est of lin e not chec ked).
  40                }
  41      GTMOD+2 4     F -  UNDEFINED  COMMAND (r est of lin e not chec ked).
  42                I (TOB=" "&(POS=2)) !(POS=86)  {   ;2-OP, 86-IPP
  43      GTMOD+2 5     F -  UNDEFINED  COMMAND (r est of lin e not chec ked).
  44                    I $D (^CHMCPF(C HMSPN,CHX, CHCMDT,1))  {
  45      GTMOD+2 6     F -  UNDEFINED  COMMAND (r est of lin e not chec ked).
  46                    }
  47      GTMOD+3 0     F -  UNDEFINED  COMMAND (r est of lin e not chec ked).
  48                }
  49      GTMOD+3 1     F -  UNDEFINED  COMMAND (r est of lin e not chec ked).
  50            }
  51      GTMOD+3 2     F -  UNDEFINED  COMMAND (r est of lin e not chec ked).
  52                    S -  Routine ex ceeds SACC  maximum s ize of 200 00 (22791) .
  53                    S -  Routine co de exceeds  SACC maxi mum size o f 15000 (1 6461).
  54  
  55   --- END -- -