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.
# | 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 |
Description | Between Files 1 and 2 |
|
---|---|---|
Text Blocks | Lines | |
Unchanged | 1 | 110 |
Changed | 0 | 0 |
Inserted | 0 | 0 |
Removed | 0 | 0 |
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 |
No regular expressions were active.
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 -- - |
Araxis Merge (but not the data content of this report) is Copyright © 1993-2016 Araxis Ltd (www.araxis.com). All rights reserved.