- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLNE3.m
r613 r623 1 PSOHLNE3 ;BIR/LE - Process Edit Information from CPRS ;02/27/04 2 ;;7.0;OUTPATIENT PHARMACY;**143,239,201,225**;DEC 1997;Build 29 3 ;External reference to ^OR(100 private DBIA 2219 4 ;External reference VADPT supported by DBIA 10061 5 ; 6 ;This API is used to update the prescription file when ICD-9 diagnosis and SC/EI's are updated as a result of an e-sig in CPRS. 7 ; 8 EN(DFN,ORITEM,ORIEN,ORDX,ORSCEI) ;ENTRY POINT 9 ; Used to import edit information from CPRS 10 ;Where Input: 11 ;DFN = Patient IEN 12 ;ORITEM = Package reference number from file 100 13 ;ORIEN = ien from file 100 14 ;ORDX(1)= (pointer to file 80) up to 8 accepted and first is primary ICD 15 ;ORDX(2)= (pointer to file 80) 16 ;ORSCEI= seven pieces - where 1=yes, 0=no, null or ? =not asked 17 ; ORSCEI=AO^IR^SC^EC^MST^HNC^CV^SHAD 18 N %,DX,DX2,DX3,RXN,PSOSCP,PSOX,ORDPROV,PSOSCP2,DA,RET,PSOANSQ,PSORX,PTSTATUS,ARRAY,PSOOI,ORITEM2,ORID,OICHK,PSORENW 19 N PSODCPY,PSONEW,PSOOIBQ,PSOFLD,PSODCZ,PSOSTAZ,PREA,PSOPIBQ,PSOIBQC,PSOSCA,PSOPICD,PSODGUP,PSOOICD,PSOPFS,TYPE,PSONW,PSOOLD,PSODA 20 N PSODD,PSOSI,X,PSOSITE,PSOBILL,PSOCPAY,PSOCICD 21 S:'$D(ORIEN) ORIEN="" S:'$D(ORSCEI) ORSCEI="" S:'$D(ORITEM) ORITEM="" 22 ; 23 ;validate prescription IEN with DFN, ord item, and placer# 24 S RET=1,PSODCZ=",12,14,15," 25 S RXN=ORITEM I '$D(^PSRX(RXN)) S RET="0^1" Q RET ;invalid RX ien 26 I $D(^PSRX(RXN,"STA")) S PSOSTAZ=^PSRX(RXN,"STA") 27 ; get prescription file patient ien, drug, and placer order # 28 D GETS^DIQ(52,RXN_",","2;6;39.3","I","ARRAY") 29 I '$D(ARRAY(52,RXN_",",2,"I")) S RET="0^3" Q RET ;quit if you don't have a patient ien 30 I ARRAY(52,RXN_",",2,"I")'=DFN S RET="0^3" Q RET ;quit if patient dfn is different 31 I '$D(ARRAY(52,RXN_",",39.3,"I")) S ARRAY(52,RXN_",",39.3,"I")="" ;if don't have it; treat is as null 32 I ARRAY(52,RXN_",",39.3,"I")'="" I ARRAY(52,RXN_",",39.3,"I")'=ORIEN S RET="0^5" Q RET ;placer # is different 33 I ARRAY(52,RXN_",",39.3,"I")="" S OICHK=0 D CHKOI I OICHK S RET="0^4" Q RET ;quit if placer # is null and orderable item is different or null. 34 ;end of validation process 35 ; 36 S PSODD=$$GET1^DIQ(52,RXN_",",6,"I") S:($P($G(^PSDRUG(PSODD,0)),"^",3)["S")!($P($G(^(0)),"^",3)["I") PSOSI=1 37 S PSOPIBQ=$G(^PSRX(RXN,"IBQ")),PSOPICD=$P($G(^PSRX(RXN,"ICD",1,0)),"^",2,8) 38 S PSOX("IRXN")=RXN,PSORENW("IRXN")=RXN 39 S (PSONEW("PATIENT STATUS"),PTSTATUS)=$$GET1^DIQ(52,RXN_",","3","I") 40 I '$D(PTSTATUS) S (PSONEW("PATIENT STATUS"),PTSTATUS)="" 41 ;if patient status is null, treat same as PSONEW2, PSORN52, PSONEWG, AND PSONEWF. If piece 7 of ^PS(53 doesn't equal 1, it's not exempt from copay. 42 I ORSCEI["?" S ORSCEI=$TR(ORSCEI,"?","") 43 D SCP^PSORN52D 44 S PSOANSQ(PSOX("IRXN"),"VEH")=$P(ORSCEI,U,1) 45 S PSOANSQ(PSOX("IRXN"),"RAD")=$P(ORSCEI,U,2) 46 I PSOSCP<50&($P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)'=1) S PSOANSQ(PSOX("IRXN"),"SC")=$P(ORSCEI,U,3),PSOANSQ("SC")=$P(ORSCEI,U,3) 47 I PSOSCP>49!($P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)=1) S PSOANSQ(PSOX("IRXN"),"SC>50")=$P(ORSCEI,U,3),PSOANSQ("SC>50")=$P(ORSCEI,U,3) 48 I PSOSCP=""&('$D(PSOANSQ("SC")))&($D(^PSRX(RXN,"ICD",1))) S PSOANSQ("SC")=$P(^PSRX(RXN,"ICD",1,0),"^",4),PSOANSQ(PSOX("IRXN"),"SC")=PSOANSQ("SC") ;for SC with no percentage defined/ legacy 49 S PSOANSQ(PSOX("IRXN"),"PGW")=$P(ORSCEI,U,4) 50 S PSOANSQ(PSOX("IRXN"),"MST")=$P(ORSCEI,U,5) 51 S PSOANSQ(PSOX("IRXN"),"HNC")=$P(ORSCEI,U,6) 52 S PSOANSQ(PSOX("IRXN"),"CV")=$P(ORSCEI,U,7) 53 S PSOANSQ(PSOX("IRXN"),"SHAD")=$P(ORSCEI,U,8) 54 D:'$$PATCH^XPDUTL("OR*3.0*243") SHAD^PSORN52D 55 S DX="",DX2=0 F S DX=$O(ORDX(DX)) Q:DX="" S DX2=DX2+1,PSORX("ICD",DX2)=ORDX(DX) ;Multi signed Rx's come in consecutively and the diagnosis subscript doesn't start with 1 for each Rx 56 S PSOSCP2=1 ;used in PSORN52D 57 ; 58 ICD2 ;Check to see if SC/EI changed during CPRS sign order 59 D GETS^DIQ(52,PSOX("IRXN")_",","52311*","I","PSOOICD") 60 S PSODCPY=0,PSOFLD="" 61 F TYPE="VEH","RAD","SC>50","PGW","MST","HNC","CV","SHAD" Q:PSODCPY F PSOFLD=1:1:8 D Q:PSODCPY 62 . I TYPE="VEH"&(PSOFLD=1) D CHOC 63 . I TYPE="RAD"&(PSOFLD=2) D CHOC 64 . I TYPE="SC>50"&(PSOFLD=3)&($D(PSOANSQ(PSOX("IRXN"),TYPE))) D CHOC 65 . I TYPE="PGW"&(PSOFLD=4) D CHOC 66 . I TYPE="MST"&(PSOFLD=5) D CHOC 67 . I TYPE="HNC"&(PSOFLD=6) D CHOC 68 . I TYPE="CV"&(PSOFLD=7) D CHOC 69 . I TYPE="SHAD"&(PSOFLD=8) D:$$PATCH^XPDUTL("OR*3.0*243") CHOC 70 I $D(PSOANSQ("SC")) S PSOFLD=3 S:PSOANSQ("SC")'=PSOOICD(52.052311,1_","_PSOX("IRXN")_",",PSOFLD,"I") PSODCPY=1,PSOFLD="" 71 ; IF NO SC/EI DIFFERENCES, CHECK FOR ICD CHANGES. If there were SC/EI difference, don't need to check ICD because they are sent anyway when copay update is done. 72 I '$G(PSODCPY) D 73 .I '$D(PSORX("ICD"))&($G(PSOOICD(52.052311,1_","_RXN_",",.01,"I"))) S PSODGUP=1 Q ;if no ICD's passed and ICD's defined in 52, CPRS overrides OP 74 .S (DX3,DX2,DX)="" F S DX=$O(PSOOICD(52.052311,DX)) Q:DX="" S DX2=+DX ;get last entry for file 52 75 .S DX="" F S DX=$O(PSORX("ICD",DX)) Q:DX="" S DX3=DX D ;get last entry for new ICD's from CPRS 76 .. I $G(PSOOICD(52.052311,DX_","_PSOX("IRXN")_",",.01,"I"))'=PSORX("ICD",DX) S PSODGUP=1 ;if ICD'S changed or more new ICD's than old ones. 77 .I DX2>DX3 S PSODGUP=1 ;if more old ICD's than new ones 78 Q:'$G(PSODCPY)&('$G(PSODGUP)) 1 79 D FILE2^PSORN52D ;file SC/EI/ICD'S into Rx file 80 ;S PSOCIDC=$P($G(^PSRX(RXN,"ICD",1,0)),"^",2,8) 81 ;only do copay if SC/EI changed and SC is less than 50%. 82 I PSODCZ[(","_$G(PSOSTAZ)_",") S RET="0^6" Q RET ;discontinue's no copay changes allowed. 83 ; 84 ;Get last fill number 85 N PSOLFIL S PSOLFIL=$$LF^PSOPFSU1(RXN) 86 S PSOPFS=$P($S('PSOLFIL:$G(^PSRX(RXN,"PFS")),1:$G(^PSRX(RXN,1,PSOLFIL,"PFS"))),"^",1,2) 87 ; No-copay to copay updates 88 S PSOIBQC=$G(^PSRX(RXN,"IBQ")),PSOCICD=$P($G(^PSRX(RXN,"ICD",1,0)),"^",2,8) 89 D CPAY 90 ; must check IBQ node in case it's a pre-CIDC rx/copay, ICD node for exempt/supply items, and for diagnosis updates for NSC Rx's 91 I (PSOPIBQ[1&(PSOIBQC'[1))!(PSOIBQC=""&(PSOPICD[1&(PSOCICD'[1)))!($G(PSODGUP)) D Q RET ;don't do no copay to copay bills, but update status 92 . D ALOG 93 . I (PSOSCP<50)&($G(PSODCPY)) D 94 .. I $P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)'=1&('$G(PSOSI)) D 95 ... S:+$G(PSOCPAY)<1&($D(^PSRX(RXN,"IB"))) $P(^PSRX(RXN,"IB"),"^",1)="" 96 ... I +$G(PSOCPAY)>0 S $P(^PSRX(RXN,"IB"),"^",1)=+$G(PSOCPAY),PSOOLD="No Copay",PSONW="Copay",PREA="R",PSODA=RXN D:'$G(PSOSI) ACTLOG^PSOCPA 97 . I +$G(PSOPFS)>0&('$P($G(PSOPFS),"^",2)) K PSOPFS Q ;don't send unreleased charge msg 98 . I +$G(PSOPFS)<1 K PSOPFS ;invalid PFSS ACCT REF/ SEND TO IB 99 . I +$G(PSOPFS)>0 S PSOPFS="1^"_PSOPFS 100 . ; 101 . I +$G(PSOPFS) D CHRG^PSOPFSU1(RXN,PSOLFIL,"CG",PSOPFS) ;always send to external bill sys 102 ; 103 ; Copay to no-copay updates 104 I $G(PSODCPY) D COPAY^PSOHLNE4 105 ;ICD UPDATE ONLY FOR COPAYS 106 I ('$G(PSODCPY)&($G(PSODGUP)))&($P($G(PSOPFS),"^",2)) D CHRG^PSOPFSU1(RXN,PSOLFIL,"CG",PSOPFS) ;DIAGNOSIS UPDATE ONLY 107 I ($G(PSODCPY)!($G(PSODGUP))) D ALOG 108 Q RET 109 ; 110 CPAY ; 111 N X,Y,III,ACTYP,BL 112 S PSOSITE=$P(^PSRX(RXN,2),"^",9) 113 S X=$P($G(^PS(59,+PSOSITE,"IB")),"^")_"^"_DFN D XTYPE^IBARX 114 S (ACTYP,BL)="",(PSOBILL,PSOCPAY)=0 115 CPAY1 ; 116 S ACTYP=$O(Y(ACTYP)) G:'ACTYP CSKP F III=0:0 S BL=$O(Y(ACTYP,BL)) Q:BL="" I BL>0 S PSOBILL=BL,PSOCPAY=BL_"^"_Y(ACTYP,BL) 117 G CPAY1 118 CSKP ; 119 S:$G(PSOSI) PSOCPAY=0 ;Supply item/investigational drug 120 S:$P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)=1 PSOCPAY=0 ;Rx Patient Status exempt 121 I PSOIBQC'="" S:PSOIBQC'[1 PSOCPAY=1 ;Yes SC/EI from CPRS 122 I (PSOBILL'>0)!(PSOCPAY=0) S PSOCPAY=0 ;INELIGIBLE 123 Q 124 ; 125 CHOC ;check outpatient classifications 126 S:PSOANSQ(PSOX("IRXN"),TYPE)'=PSOOICD(52.052311,1_","_PSOX("IRXN")_",",PSOFLD,"I") PSODCPY=1 127 Q 128 ; 129 ALOG ;set activity log with edit info from cprs 130 N ACNT,SUB,RF,RFCNT 131 S ACNT=0 F SUB=0:0 S SUB=$O(^PSRX(RXN,"A",SUB)) Q:'SUB S ACNT=SUB 132 S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(RXN,1,RF)) Q:'RF S RFCNT=RF S:RF>5 RFCNT=RF+1 133 D NOW^%DTC S ACNT=ACNT+1 134 S ^PSRX(RXN,"A",0)="^52.3DA^"_ACNT_"^"_ACNT S ^PSRX(RXN,"A",ACNT,0)=%_"^"_"E"_"^^"_RFCNT_"^Clinical Indicators and SC/EI's were updated from a CPRS e-sig edit at "_$E($P(%,".",2),1,2)_":"_$E($P(%,".",2),3,4)_"." 135 Q 136 ; 137 CHKOI ;get and compare orderable items in file #100 and #52; don't process 138 ; if it's different and the placer # is null. 139 I '$D(ARRAY(52,RXN_",",6,"I")) S OICHK=1 Q 140 D GETS^DIQ(50,ARRAY(52,RXN_",",6,"I")_",","2.1","I","PSOOI") 141 S ORITEM2=$$GET1^DIQ(100.001,"1,"_ORIEN_",",".01","I") 142 S ORID=$$GET1^DIQ(101.43,ORITEM2_",","2","I") S ORID=$P(ORID,";",1) 143 I PSOOI(50,ARRAY(52,RXN_",",6,"I")_",",2.1,"I")'="" I PSOOI(50,ARRAY(52,RXN_",",6,"I")_",",2.1,"I")'=ORID S OICHK=1 144 Q 145 TEST(ORIEN) ;manually test an individual order record 146 N I,X,ORSCEIS,ORSCEI,ORDX,EDFLG,ORITEM,DFN,JJ 147 S (JJ,I)=0 F S I=$O(^OR(100,ORIEN,5.1,I)) Q:I=""!(I'?1N.NN) S JJ=JJ+1,ORDX(JJ)=$G(^OR(100,ORIEN,5.1,I,0)) 148 S ORSCEIS=^OR(100,ORIEN,5.2),ORITEM=$P($G(^OR(100,ORIEN,4)),"^",1) 149 S ORSCEI="" F I=3,4,1,5,2,6,7 S ORSCEI=ORSCEI_"^"_$P(ORSCEIS,"^",I) 150 S:$$PATCH^XPDUTL("OR*3.0*243") ORSCEI=ORSCEI_"^"_$P(ORSCEIS,"^",8) 151 S ORSCEI=$E(ORSCEI,2,99) 152 S RXN=ORITEM,DFN=$P($P(^OR(100,ORIEN,0),"^",2),";",1) 153 D EN^PSOHLNE3(DFN,ORITEM,ORIEN,.ORDX,ORSCEI) 154 Q 155 OBXNTE ; Called from PSOHLNEW due to it's routine size. 156 S LL=ZZ+1,PSOBCT=2 157 I $P($G(MSG(LL)),"|")="NTE" D 158 .I $P(MSG(LL),"|",4)'="" S PSOBCT=3,OBXAR(OCOUNT,2)=$P(MSG(LL),"|",4) 159 .F LLL=0:0 S LLL=$O(MSG(LL,LLL)) Q:'LLL D 160 ..I $P($G(MSG(LL,LLL)),"|",4)'="" S OBXAR(OCOUNT,PSOBCT)=$P(MSG(LL,LLL),"|",4),PSOBCT=PSOBCT+1 161 Q 1 PSOHLNE3 ;BIR/LE - Process Edit Information from CPRS ;02/27/04 2 ;;7.0;OUTPATIENT PHARMACY;**143,239,201**;DEC 1997 3 ;External reference to ^OR(100 private DBIA 2219 4 ;External reference VADPT supported by DBIA 10061 5 ; 6 ;This API is used to update the prescription file when ICD-9 diagnosis and SC/EI's are updated as a result of an e-sig in CPRS. 7 ; 8 EN(DFN,ORITEM,ORIEN,ORDX,ORSCEI) ;ENTRY POINT 9 ; Used to import edit information from CPRS 10 ;Where Input: 11 ;DFN = Patient IEN 12 ;ORITEM = Package reference number from file 100 13 ;ORIEN = ien from file 100 14 ;ORDX(1)= (pointer to file 80) up to 8 accepted and first is primary ICD 15 ;ORDX(2)= (pointer to file 80) 16 ;ORSCEI= seven pieces - where 1=yes, 0=no, null or ? =not asked 17 ; ORSCEI=AO^IR^SC^EC^MST^HNC^CV 18 N %,DX,DX2,DX3,RXN,PSOSCP,PSOX,ORDPROV,PSOSCP2,DA,RET,PSOANSQ,PSORX,PTSTATUS,ARRAY,PSOOI,ORITEM2,ORID,OICHK,PSORENW 19 N PSODCPY,PSONEW,PSOOIBQ,PSOFLD,PSODCZ,PSOSTAZ,PREA,PSOPIBQ,PSOIBQC,PSOSCA,PSOPICD,PSODGUP,PSOOICD,PSOPFS,TYPE,PSONW,PSOOLD,PSODA 20 N PSODD,PSOSI,X,PSOSITE,PSOBILL,PSOCPAY,PSOCICD 21 S:'$D(ORIEN) ORIEN="" S:'$D(ORSCEI) ORSCEI="" S:'$D(ORITEM) ORITEM="" 22 ; 23 ;validate prescription IEN with DFN, ord item, and placer# 24 S RET=1,PSODCZ=",12,14,15," 25 S RXN=ORITEM I '$D(^PSRX(RXN)) S RET="0^1" Q RET ;invalid RX ien 26 I $D(^PSRX(RXN,"STA")) S PSOSTAZ=^PSRX(RXN,"STA") 27 ; get prescription file patient ien, drug, and placer order # 28 D GETS^DIQ(52,RXN_",","2;6;39.3","I","ARRAY") 29 I '$D(ARRAY(52,RXN_",",2,"I")) S RET="0^3" Q RET ;quit if you don't have a patient ien 30 I ARRAY(52,RXN_",",2,"I")'=DFN S RET="0^3" Q RET ;quit if patient dfn is different 31 I '$D(ARRAY(52,RXN_",",39.3,"I")) S ARRAY(52,RXN_",",39.3,"I")="" ;if don't have it; treat is as null 32 I ARRAY(52,RXN_",",39.3,"I")'="" I ARRAY(52,RXN_",",39.3,"I")'=ORIEN S RET="0^5" Q RET ;placer # is different 33 I ARRAY(52,RXN_",",39.3,"I")="" S OICHK=0 D CHKOI I OICHK S RET="0^4" Q RET ;quit if placer # is null and orderable item is different or null. 34 ;end of validation process 35 ; 36 S PSODD=$$GET1^DIQ(52,RXN_",",6,"I") S:($P($G(^PSDRUG(PSODD,0)),"^",3)["S")!($P($G(^(0)),"^",3)["I") PSOSI=1 37 S PSOPIBQ=$G(^PSRX(RXN,"IBQ")),PSOPICD=$P($G(^PSRX(RXN,"ICD",1,0)),"^",2,7) 38 S PSOX("IRXN")=RXN,PSORENW("IRXN")=RXN 39 S (PSONEW("PATIENT STATUS"),PTSTATUS)=$$GET1^DIQ(52,RXN_",","3","I") 40 I '$D(PTSTATUS) S (PSONEW("PATIENT STATUS"),PTSTATUS)="" 41 ;if patient status is null, treat same as PSONEW2, PSORN52, PSONEWG, AND PSONEWF. If piece 7 of ^PS(53 doesn't equal 1, it's not exempt from copay. 42 I ORSCEI["?" S ORSCEI=$TR(ORSCEI,"?","") 43 D SCP^PSORN52D 44 S PSOANSQ(PSOX("IRXN"),"VEH")=$P(ORSCEI,U,1) 45 S PSOANSQ(PSOX("IRXN"),"RAD")=$P(ORSCEI,U,2) 46 I PSOSCP<50&($P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)'=1) S PSOANSQ(PSOX("IRXN"),"SC")=$P(ORSCEI,U,3),PSOANSQ("SC")=$P(ORSCEI,U,3) 47 I PSOSCP>49!($P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)=1) S PSOANSQ(PSOX("IRXN"),"SC>50")=$P(ORSCEI,U,3),PSOANSQ("SC>50")=$P(ORSCEI,U,3) 48 I PSOSCP=""&('$D(PSOANSQ("SC")))&($D(^PSRX(RXN,"ICD",1))) S PSOANSQ("SC")=$P(^PSRX(RXN,"ICD",1,0),"^",4),PSOANSQ(PSOX("IRXN"),"SC")=PSOANSQ("SC") ;for SC with no percentage defined/ legacy 49 S PSOANSQ(PSOX("IRXN"),"PGW")=$P(ORSCEI,U,4) 50 S PSOANSQ(PSOX("IRXN"),"MST")=$P(ORSCEI,U,5) 51 S PSOANSQ(PSOX("IRXN"),"HNC")=$P(ORSCEI,U,6) 52 S PSOANSQ(PSOX("IRXN"),"CV")=$P(ORSCEI,U,7) 53 ; 54 S DX="",DX2=0 F S DX=$O(ORDX(DX)) Q:DX="" S DX2=DX2+1,PSORX("ICD",DX2)=ORDX(DX) ;Multi signed Rx's come in consecutively and the diagnosis subscript doesn't start with 1 for each Rx 55 S PSOSCP2=1 ;used in PSORN52D 56 ; 57 ICD2 ;Check to see if SC/EI changed during CPRS sign order 58 D GETS^DIQ(52,PSOX("IRXN")_",","52311*","I","PSOOICD") 59 S PSODCPY=0,PSOFLD="" 60 F TYPE="VEH","RAD","SC>50","PGW","MST","HNC","CV" Q:PSODCPY F PSOFLD=1:1:7 D Q:PSODCPY 61 . I TYPE="VEH"&(PSOFLD=1) D CHOC 62 . I TYPE="RAD"&(PSOFLD=2) D CHOC 63 . I TYPE="SC>50"&(PSOFLD=3)&($D(PSOANSQ(PSOX("IRXN"),TYPE))) D CHOC 64 . I TYPE="PGW"&(PSOFLD=4) D CHOC 65 . I TYPE="MST"&(PSOFLD=5) D CHOC 66 . I TYPE="HNC"&(PSOFLD=6) D CHOC 67 . I TYPE="CV"&(PSOFLD=7) D CHOC 68 I $D(PSOANSQ("SC")) S PSOFLD=3 S:PSOANSQ("SC")'=PSOOICD(52.052311,1_","_PSOX("IRXN")_",",PSOFLD,"I") PSODCPY=1,PSOFLD="" 69 ; IF NO SC/EI DIFFERENCES, CHECK FOR ICD CHANGES. If there were SC/EI difference, don't need to check ICD because they are sent anyway when copay update is done. 70 I '$G(PSODCPY) D 71 .I '$D(PSORX("ICD"))&($G(PSOOICD(52.052311,1_","_RXN_",",.01,"I"))) S PSODGUP=1 Q ;if no ICD's passed and ICD's defined in 52, CPRS overrides OP 72 .S (DX3,DX2,DX)="" F S DX=$O(PSOOICD(52.052311,DX)) Q:DX="" S DX2=+DX ;get last entry for file 52 73 .S DX="" F S DX=$O(PSORX("ICD",DX)) Q:DX="" S DX3=DX D ;get last entry for new ICD's from CPRS 74 .. I $G(PSOOICD(52.052311,DX_","_PSOX("IRXN")_",",.01,"I"))'=PSORX("ICD",DX) S PSODGUP=1 ;if ICD'S changed or more new ICD's than old ones. 75 .I DX2>DX3 S PSODGUP=1 ;if more old ICD's than new ones 76 Q:'$G(PSODCPY)&('$G(PSODGUP)) 1 77 D FILE2^PSORN52D ;file SC/EI/ICD'S into Rx file 78 ;S PSOCIDC=$P($G(^PSRX(RXN,"ICD",1,0)),"^",2,7) 79 ;only do copay if SC/EI changed and SC is less than 50%. 80 I PSODCZ[(","_$G(PSOSTAZ)_",") S RET="0^6" Q RET ;discontinue's no copay changes allowed. 81 ; 82 ;Get last fill number 83 N PSOLFIL S PSOLFIL=$$LF^PSOPFSU1(RXN) 84 S PSOPFS=$P($S('PSOLFIL:$G(^PSRX(RXN,"PFS")),1:$G(^PSRX(RXN,1,PSOLFIL,"PFS"))),"^",1,2) 85 ; No-copay to copay updates 86 S PSOIBQC=$G(^PSRX(RXN,"IBQ")),PSOCICD=$P($G(^PSRX(RXN,"ICD",1,0)),"^",2,7) 87 D CPAY 88 ; must check IBQ node in case it's a pre-CIDC rx/copay, ICD node for exempt/supply items, and for diagnosis updates for NSC Rx's 89 I (PSOPIBQ[1&(PSOIBQC'[1))!(PSOIBQC=""&(PSOPICD[1&(PSOCICD'[1)))!($G(PSODGUP)) D Q RET ;don't do no copay to copay bills, but update status 90 . D ALOG 91 . I (PSOSCP<50)&($G(PSODCPY)) D 92 .. I $P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)'=1&('$G(PSOSI)) D 93 ... S:+$G(PSOCPAY)<1&($D(^PSRX(RXN,"IB"))) $P(^PSRX(RXN,"IB"),"^",1)="" 94 ... I +$G(PSOCPAY)>0 S $P(^PSRX(RXN,"IB"),"^",1)=+$G(PSOCPAY),PSOOLD="No Copay",PSONW="Copay",PREA="R",PSODA=RXN D:'$G(PSOSI) ACTLOG^PSOCPA 95 . I +$G(PSOPFS)>0&('$P($G(PSOPFS),"^",2)) K PSOPFS Q ;don't send unreleased charge msg 96 . I +$G(PSOPFS)<1 K PSOPFS ;invalid PFSS ACCT REF/ SEND TO IB 97 . I +$G(PSOPFS)>0 S PSOPFS="1^"_PSOPFS 98 . ; 99 . I +$G(PSOPFS) D CHRG^PSOPFSU1(RXN,PSOLFIL,"CG",PSOPFS) ;always send to external bill sys 100 ; 101 ; Copay to no-copay updates 102 I $G(PSODCPY) D COPAY^PSOHLNE4 103 ;ICD UPDATE ONLY FOR COPAYS 104 I ('$G(PSODCPY)&($G(PSODGUP)))&($P($G(PSOPFS),"^",2)) D CHRG^PSOPFSU1(RXN,PSOLFIL,"CG",PSOPFS) ;DIAGNOSIS UPDATE ONLY 105 I ($G(PSODCPY)!($G(PSODGUP))) D ALOG 106 Q RET 107 ; 108 CPAY ; 109 N X,Y,III,ACTYP,BL 110 S PSOSITE=$P(^PSRX(RXN,2),"^",9) 111 S X=$P($G(^PS(59,+PSOSITE,"IB")),"^")_"^"_DFN D XTYPE^IBARX 112 S (ACTYP,BL)="",(PSOBILL,PSOCPAY)=0 113 CPAY1 ; 114 S ACTYP=$O(Y(ACTYP)) G:'ACTYP CSKP F III=0:0 S BL=$O(Y(ACTYP,BL)) Q:BL="" I BL>0 S PSOBILL=BL,PSOCPAY=BL_"^"_Y(ACTYP,BL) 115 G CPAY1 116 CSKP ; 117 S:$G(PSOSI) PSOCPAY=0 ;Supply item/investigational drug 118 S:$P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)=1 PSOCPAY=0 ;Rx Patient Status exempt 119 I PSOIBQC'="" S:PSOIBQC'[1 PSOCPAY=1 ;Yes SC/EI from CPRS 120 I (PSOBILL'>0)!(PSOCPAY=0) S PSOCPAY=0 ;INELIGIBLE 121 Q 122 ; 123 CHOC ;check outpatient classifications 124 S:PSOANSQ(PSOX("IRXN"),TYPE)'=PSOOICD(52.052311,1_","_PSOX("IRXN")_",",PSOFLD,"I") PSODCPY=1 125 Q 126 ; 127 ALOG ;set activity log with edit info from cprs 128 N ACNT,SUB,RF,RFCNT 129 S ACNT=0 F SUB=0:0 S SUB=$O(^PSRX(RXN,"A",SUB)) Q:'SUB S ACNT=SUB 130 S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(RXN,1,RF)) Q:'RF S RFCNT=RF S:RF>5 RFCNT=RF+1 131 D NOW^%DTC S ACNT=ACNT+1 132 S ^PSRX(RXN,"A",0)="^52.3DA^"_ACNT_"^"_ACNT S ^PSRX(RXN,"A",ACNT,0)=%_"^"_"E"_"^^"_RFCNT_"^Clinical Indicators and SC/EI's were updated from a CPRS e-sig edit at "_$E($P(%,".",2),1,2)_":"_$E($P(%,".",2),3,4)_"." 133 Q 134 ; 135 CHKOI ;get and compare orderable items in file #100 and #52; don't process 136 ; if it's different and the placer # is null. 137 I '$D(ARRAY(52,RXN_",",6,"I")) S OICHK=1 Q 138 D GETS^DIQ(50,ARRAY(52,RXN_",",6,"I")_",","2.1","I","PSOOI") 139 S ORITEM2=$$GET1^DIQ(100.001,"1,"_ORIEN_",",".01","I") 140 S ORID=$$GET1^DIQ(101.43,ORITEM2_",","2","I") S ORID=$P(ORID,";",1) 141 I PSOOI(50,ARRAY(52,RXN_",",6,"I")_",",2.1,"I")'="" I PSOOI(50,ARRAY(52,RXN_",",6,"I")_",",2.1,"I")'=ORID S OICHK=1 142 Q 143 TEST(ORIEN) ;manually test an individual order record 144 N I,X,ORSCEIS,ORSCEI,ORDX,EDFLG,ORITEM,DFN,JJ 145 S (JJ,I)=0 F S I=$O(^OR(100,ORIEN,5.1,I)) Q:I=""!(I'?1N.NN) S JJ=JJ+1,ORDX(JJ)=$G(^OR(100,ORIEN,5.1,I,0)) 146 S ORSCEIS=^OR(100,ORIEN,5.2),ORITEM=$P($G(^OR(100,ORIEN,4)),"^",1) 147 S ORSCEI="" F I=3,4,1,5,2,6,7 S ORSCEI=ORSCEI_"^"_$P(ORSCEIS,"^",I) 148 S ORSCEI=$E(ORSCEI,2,99) 149 S RXN=ORITEM,DFN=$P($P(^OR(100,ORIEN,0),"^",2),";",1) 150 D EN^PSOHLNE3(DFN,ORITEM,ORIEN,.ORDX,ORSCEI) 151 Q
Note:
See TracChangeset
for help on using the changeset viewer.
