- PSOHLNE3 ;BIR/LE - Process Edit Information from CPRS ;02/27/04
- ;;7.0;OUTPATIENT PHARMACY;**143,239,201,225,303**;DEC 1997;Build 19
- ;External reference to ^OR(100 private DBIA 2219
- ;External reference VADPT supported by DBIA 10061
- ;
- ;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.
- ;
- EN(DFN,ORITEM,ORIEN,ORDX,ORSCEI) ;ENTRY POINT
- ; Used to import edit information from CPRS
- ;Where Input:
- ;DFN = Patient IEN
- ;ORITEM = Package reference number from file 100
- ;ORIEN = ien from file 100
- ;ORDX(1)= (pointer to file 80) up to 8 accepted and first is primary ICD
- ;ORDX(2)= (pointer to file 80)
- ;ORSCEI= seven pieces - where 1=yes, 0=no, null or ? =not asked
- ; ORSCEI=AO^IR^SC^EC^MST^HNC^CV^SHAD
- N %,DX,DX2,DX3,RXN,PSOSCP,PSOX,ORDPROV,PSOSCP2,DA,RET,PSOANSQ,PSORX,PTSTATUS,ARRAY,PSOOI,ORITEM2,ORID,OICHK,PSORENW
- N PSODCPY,PSONEW,PSOOIBQ,PSOFLD,PSODCZ,PSOSTAZ,PREA,PSOPIBQ,PSOIBQC,PSOSCA,PSOPICD,PSODGUP,PSOOICD,PSOPFS,TYPE,PSONW,PSOOLD,PSODA
- N PSODD,PSOSI,X,PSOSITE,PSOBILL,PSOCPAY,PSOCICD
- S:'$D(ORIEN) ORIEN="" S:'$D(ORSCEI) ORSCEI="" S:'$D(ORITEM) ORITEM=""
- ;
- ;validate prescription IEN with DFN, ord item, and placer#
- S RET=1,PSODCZ=",12,14,15,"
- S RXN=ORITEM I '$D(^PSRX(RXN)) S RET="0^1" Q RET ;invalid RX ien
- I $D(^PSRX(RXN,"STA")) S PSOSTAZ=^PSRX(RXN,"STA")
- ; get prescription file patient ien, drug, and placer order #
- D GETS^DIQ(52,RXN_",","2;6;39.3","I","ARRAY")
- I '$D(ARRAY(52,RXN_",",2,"I")) S RET="0^3" Q RET ;quit if you don't have a patient ien
- I ARRAY(52,RXN_",",2,"I")'=DFN S RET="0^3" Q RET ;quit if patient dfn is different
- I '$D(ARRAY(52,RXN_",",39.3,"I")) S ARRAY(52,RXN_",",39.3,"I")="" ;if don't have it; treat is as null
- I ARRAY(52,RXN_",",39.3,"I")'="" I ARRAY(52,RXN_",",39.3,"I")'=ORIEN S RET="0^5" Q RET ;placer # is different
- 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.
- ;end of validation process
- ;
- S PSODD=$$GET1^DIQ(52,RXN_",",6,"I") S:($P($G(^PSDRUG(PSODD,0)),"^",3)["S")!($P($G(^(0)),"^",3)["I")!($P($G(^(0)),"^",3)["N") PSOSI=1
- S PSOPIBQ=$G(^PSRX(RXN,"IBQ")),PSOPICD=$P($G(^PSRX(RXN,"ICD",1,0)),"^",2,8)
- S PSOX("IRXN")=RXN,PSORENW("IRXN")=RXN
- S (PSONEW("PATIENT STATUS"),PTSTATUS)=$$GET1^DIQ(52,RXN_",","3","I")
- I '$D(PTSTATUS) S (PSONEW("PATIENT STATUS"),PTSTATUS)=""
- ;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.
- I ORSCEI["?" S ORSCEI=$TR(ORSCEI,"?","")
- D SCP^PSORN52D
- S PSOANSQ(PSOX("IRXN"),"VEH")=$P(ORSCEI,U,1)
- S PSOANSQ(PSOX("IRXN"),"RAD")=$P(ORSCEI,U,2)
- 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)
- 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)
- 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
- S PSOANSQ(PSOX("IRXN"),"PGW")=$P(ORSCEI,U,4)
- S PSOANSQ(PSOX("IRXN"),"MST")=$P(ORSCEI,U,5)
- S PSOANSQ(PSOX("IRXN"),"HNC")=$P(ORSCEI,U,6)
- S PSOANSQ(PSOX("IRXN"),"CV")=$P(ORSCEI,U,7)
- S PSOANSQ(PSOX("IRXN"),"SHAD")=$P(ORSCEI,U,8)
- D:'$$PATCH^XPDUTL("OR*3.0*243") SHAD^PSORN52D
- 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
- S PSOSCP2=1 ;used in PSORN52D
- ;
- ICD2 ;Check to see if SC/EI changed during CPRS sign order
- D GETS^DIQ(52,PSOX("IRXN")_",","52311*","I","PSOOICD")
- S PSODCPY=0,PSOFLD=""
- F TYPE="VEH","RAD","SC>50","PGW","MST","HNC","CV","SHAD" Q:PSODCPY F PSOFLD=1:1:8 D Q:PSODCPY
- . I TYPE="VEH"&(PSOFLD=1) D CHOC
- . I TYPE="RAD"&(PSOFLD=2) D CHOC
- . I TYPE="SC>50"&(PSOFLD=3)&($D(PSOANSQ(PSOX("IRXN"),TYPE))) D CHOC
- . I TYPE="PGW"&(PSOFLD=4) D CHOC
- . I TYPE="MST"&(PSOFLD=5) D CHOC
- . I TYPE="HNC"&(PSOFLD=6) D CHOC
- . I TYPE="CV"&(PSOFLD=7) D CHOC
- . I TYPE="SHAD"&(PSOFLD=8) D:$$PATCH^XPDUTL("OR*3.0*243") CHOC
- I $D(PSOANSQ("SC")) S PSOFLD=3 S:PSOANSQ("SC")'=PSOOICD(52.052311,1_","_PSOX("IRXN")_",",PSOFLD,"I") PSODCPY=1,PSOFLD=""
- ; 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.
- I '$G(PSODCPY) D
- .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
- .S (DX3,DX2,DX)="" F S DX=$O(PSOOICD(52.052311,DX)) Q:DX="" S DX2=+DX ;get last entry for file 52
- .S DX="" F S DX=$O(PSORX("ICD",DX)) Q:DX="" S DX3=DX D ;get last entry for new ICD's from CPRS
- .. 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.
- .I DX2>DX3 S PSODGUP=1 ;if more old ICD's than new ones
- Q:'$G(PSODCPY)&('$G(PSODGUP)) 1
- D FILE2^PSORN52D ;file SC/EI/ICD'S into Rx file
- ;S PSOCIDC=$P($G(^PSRX(RXN,"ICD",1,0)),"^",2,8)
- ;only do copay if SC/EI changed and SC is less than 50%.
- I PSODCZ[(","_$G(PSOSTAZ)_",") S RET="0^6" Q RET ;discontinue's no copay changes allowed.
- ;
- ;Get last fill number
- N PSOLFIL S PSOLFIL=$$LF^PSOPFSU1(RXN)
- S PSOPFS=$P($S('PSOLFIL:$G(^PSRX(RXN,"PFS")),1:$G(^PSRX(RXN,1,PSOLFIL,"PFS"))),"^",1,2)
- ; No-copay to copay updates
- S PSOIBQC=$G(^PSRX(RXN,"IBQ")),PSOCICD=$P($G(^PSRX(RXN,"ICD",1,0)),"^",2,8)
- D CPAY
- ; 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
- 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
- . D ALOG
- . I (PSOSCP<50)&($G(PSODCPY)) D
- .. I $P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)'=1&('$G(PSOSI)) D
- ... S:+$G(PSOCPAY)<1&($D(^PSRX(RXN,"IB"))) $P(^PSRX(RXN,"IB"),"^",1)=""
- ... 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
- . I +$G(PSOPFS)>0&('$P($G(PSOPFS),"^",2)) K PSOPFS Q ;don't send unreleased charge msg
- . I +$G(PSOPFS)<1 K PSOPFS ;invalid PFSS ACCT REF/ SEND TO IB
- . I +$G(PSOPFS)>0 S PSOPFS="1^"_PSOPFS
- . ;
- . I +$G(PSOPFS) D CHRG^PSOPFSU1(RXN,PSOLFIL,"CG",PSOPFS) ;always send to external bill sys
- ;
- ; Copay to no-copay updates
- I $G(PSODCPY) D COPAY^PSOHLNE4
- ;ICD UPDATE ONLY FOR COPAYS
- I ('$G(PSODCPY)&($G(PSODGUP)))&($P($G(PSOPFS),"^",2)) D CHRG^PSOPFSU1(RXN,PSOLFIL,"CG",PSOPFS) ;DIAGNOSIS UPDATE ONLY
- I ($G(PSODCPY)!($G(PSODGUP))) D ALOG
- Q RET
- ;
- CPAY ;
- N X,Y,III,ACTYP,BL
- S PSOSITE=$P(^PSRX(RXN,2),"^",9)
- S X=$P($G(^PS(59,+PSOSITE,"IB")),"^")_"^"_DFN D XTYPE^IBARX
- S (ACTYP,BL)="",(PSOBILL,PSOCPAY)=0
- CPAY1 ;
- 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)
- G CPAY1
- CSKP ;
- S:$G(PSOSI) PSOCPAY=0 ;Supply item/investigational drug/nutritional supplement
- S:$P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)=1 PSOCPAY=0 ;Rx Patient Status exempt
- I PSOIBQC'="" S:PSOIBQC'[1 PSOCPAY=1 ;Yes SC/EI from CPRS
- I (PSOBILL'>0)!(PSOCPAY=0) S PSOCPAY=0 ;INELIGIBLE
- Q
- ;
- CHOC ;check outpatient classifications
- S:PSOANSQ(PSOX("IRXN"),TYPE)'=PSOOICD(52.052311,1_","_PSOX("IRXN")_",",PSOFLD,"I") PSODCPY=1
- Q
- ;
- ALOG ;set activity log with edit info from cprs
- N ACNT,SUB,RF,RFCNT
- S ACNT=0 F SUB=0:0 S SUB=$O(^PSRX(RXN,"A",SUB)) Q:'SUB S ACNT=SUB
- 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
- D NOW^%DTC S ACNT=ACNT+1
- 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)_"."
- Q
- ;
- CHKOI ;get and compare orderable items in file #100 and #52; don't process
- ; if it's different and the placer # is null.
- I '$D(ARRAY(52,RXN_",",6,"I")) S OICHK=1 Q
- D GETS^DIQ(50,ARRAY(52,RXN_",",6,"I")_",","2.1","I","PSOOI")
- S ORITEM2=$$GET1^DIQ(100.001,"1,"_ORIEN_",",".01","I")
- S ORID=$$GET1^DIQ(101.43,ORITEM2_",","2","I") S ORID=$P(ORID,";",1)
- 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
- Q
- TEST(ORIEN) ;manually test an individual order record
- N I,X,ORSCEIS,ORSCEI,ORDX,EDFLG,ORITEM,DFN,JJ
- 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))
- S ORSCEIS=^OR(100,ORIEN,5.2),ORITEM=$P($G(^OR(100,ORIEN,4)),"^",1)
- S ORSCEI="" F I=3,4,1,5,2,6,7 S ORSCEI=ORSCEI_"^"_$P(ORSCEIS,"^",I)
- S:$$PATCH^XPDUTL("OR*3.0*243") ORSCEI=ORSCEI_"^"_$P(ORSCEIS,"^",8)
- S ORSCEI=$E(ORSCEI,2,99)
- S RXN=ORITEM,DFN=$P($P(^OR(100,ORIEN,0),"^",2),";",1)
- D EN^PSOHLNE3(DFN,ORITEM,ORIEN,.ORDX,ORSCEI)
- Q
- OBXNTE ; Called from PSOHLNEW due to it's routine size.
- S LL=ZZ+1,PSOBCT=2
- I $P($G(MSG(LL)),"|")="NTE" D
- .I $P(MSG(LL),"|",4)'="" S PSOBCT=3,OBXAR(OCOUNT,2)=$P(MSG(LL),"|",4)
- .F LLL=0:0 S LLL=$O(MSG(LL,LLL)) Q:'LLL D
- ..I $P($G(MSG(LL,LLL)),"|",4)'="" S OBXAR(OCOUNT,PSOBCT)=$P(MSG(LL,LLL),"|",4),PSOBCT=PSOBCT+1
- Q
- PSOHLNE3 ;BIR/LE - Process Edit Information from CPRS ;02/27/04
- +1 ;;7.0;OUTPATIENT PHARMACY;**143,239,201,225,303**;DEC 1997;Build 19
- +2 ;External reference to ^OR(100 private DBIA 2219
- +3 ;External reference VADPT supported by DBIA 10061
- +4 ;
- +5 ;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.
- +6 ;
- EN(DFN,ORITEM,ORIEN,ORDX,ORSCEI) ;ENTRY POINT
- +1 ; Used to import edit information from CPRS
- +2 ;Where Input:
- +3 ;DFN = Patient IEN
- +4 ;ORITEM = Package reference number from file 100
- +5 ;ORIEN = ien from file 100
- +6 ;ORDX(1)= (pointer to file 80) up to 8 accepted and first is primary ICD
- +7 ;ORDX(2)= (pointer to file 80)
- +8 ;ORSCEI= seven pieces - where 1=yes, 0=no, null or ? =not asked
- +9 ; ORSCEI=AO^IR^SC^EC^MST^HNC^CV^SHAD
- +10 NEW %,DX,DX2,DX3,RXN,PSOSCP,PSOX,ORDPROV,PSOSCP2,DA,RET,PSOANSQ,PSORX,PTSTATUS,ARRAY,PSOOI,ORITEM2,ORID,OICHK,PSORENW
- +11 NEW PSODCPY,PSONEW,PSOOIBQ,PSOFLD,PSODCZ,PSOSTAZ,PREA,PSOPIBQ,PSOIBQC,PSOSCA,PSOPICD,PSODGUP,PSOOICD,PSOPFS,TYPE,PSONW,PSOOLD,PSODA
- +12 NEW PSODD,PSOSI,X,PSOSITE,PSOBILL,PSOCPAY,PSOCICD
- +13 IF '$DATA(ORIEN)
- SET ORIEN=""
- IF '$DATA(ORSCEI)
- SET ORSCEI=""
- IF '$DATA(ORITEM)
- SET ORITEM=""
- +14 ;
- +15 ;validate prescription IEN with DFN, ord item, and placer#
- +16 SET RET=1
- SET PSODCZ=",12,14,15,"
- +17 ;invalid RX ien
- SET RXN=ORITEM
- IF '$DATA(^PSRX(RXN))
- SET RET="0^1"
- QUIT RET
- +18 IF $DATA(^PSRX(RXN,"STA"))
- SET PSOSTAZ=^PSRX(RXN,"STA")
- +19 ; get prescription file patient ien, drug, and placer order #
- +20 DO GETS^DIQ(52,RXN_",","2;6;39.3","I","ARRAY")
- +21 ;quit if you don't have a patient ien
- IF '$DATA(ARRAY(52,RXN_",",2,"I"))
- SET RET="0^3"
- QUIT RET
- +22 ;quit if patient dfn is different
- IF ARRAY(52,RXN_",",2,"I")'=DFN
- SET RET="0^3"
- QUIT RET
- +23 ;if don't have it; treat is as null
- IF '$DATA(ARRAY(52,RXN_",",39.3,"I"))
- SET ARRAY(52,RXN_",",39.3,"I")=""
- +24 ;placer # is different
- IF ARRAY(52,RXN_",",39.3,"I")'=""
- IF ARRAY(52,RXN_",",39.3,"I")'=ORIEN
- SET RET="0^5"
- QUIT RET
- +25 ;quit if placer # is null and orderable item is different or null.
- IF ARRAY(52,RXN_",",39.3,"I")=""
- SET OICHK=0
- DO CHKOI
- IF OICHK
- SET RET="0^4"
- QUIT RET
- +26 ;end of validation process
- +27 ;
- +28 SET PSODD=$$GET1^DIQ(52,RXN_",",6,"I")
- IF ($PIECE($GET(^PSDRUG(PSODD,0)),"^",3)["S")!($PIECE($GET(^(0)),"^",3)["I")!($PIECE($GET(^(0)),"^",3)["N")
- SET PSOSI=1
- +29 SET PSOPIBQ=$GET(^PSRX(RXN,"IBQ"))
- SET PSOPICD=$PIECE($GET(^PSRX(RXN,"ICD",1,0)),"^",2,8)
- +30 SET PSOX("IRXN")=RXN
- SET PSORENW("IRXN")=RXN
- +31 SET (PSONEW("PATIENT STATUS"),PTSTATUS)=$$GET1^DIQ(52,RXN_",","3","I")
- +32 IF '$DATA(PTSTATUS)
- SET (PSONEW("PATIENT STATUS"),PTSTATUS)=""
- +33 ;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.
- +34 IF ORSCEI["?"
- SET ORSCEI=$TRANSLATE(ORSCEI,"?","")
- +35 DO SCP^PSORN52D
- +36 SET PSOANSQ(PSOX("IRXN"),"VEH")=$PIECE(ORSCEI,U,1)
- +37 SET PSOANSQ(PSOX("IRXN"),"RAD")=$PIECE(ORSCEI,U,2)
- +38 IF PSOSCP<50&($PIECE($GET(^PS(53,+$GET(PTSTATUS),0)),"^",7)'=1)
- SET PSOANSQ(PSOX("IRXN"),"SC")=$PIECE(ORSCEI,U,3)
- SET PSOANSQ("SC")=$PIECE(ORSCEI,U,3)
- +39 IF PSOSCP>49!($PIECE($GET(^PS(53,+$GET(PTSTATUS),0)),"^",7)=1)
- SET PSOANSQ(PSOX("IRXN"),"SC>50")=$PIECE(ORSCEI,U,3)
- SET PSOANSQ("SC>50")=$PIECE(ORSCEI,U,3)
- +40 ;for SC with no percentage defined/ legacy
- IF PSOSCP=""&('$DATA(PSOANSQ("SC")))&($DATA(^PSRX(RXN,"ICD",1)))
- SET PSOANSQ("SC")=$PIECE(^PSRX(RXN,"ICD",1,0),"^",4)
- SET PSOANSQ(PSOX("IRXN"),"SC")=PSOANSQ("SC")
- +41 SET PSOANSQ(PSOX("IRXN"),"PGW")=$PIECE(ORSCEI,U,4)
- +42 SET PSOANSQ(PSOX("IRXN"),"MST")=$PIECE(ORSCEI,U,5)
- +43 SET PSOANSQ(PSOX("IRXN"),"HNC")=$PIECE(ORSCEI,U,6)
- +44 SET PSOANSQ(PSOX("IRXN"),"CV")=$PIECE(ORSCEI,U,7)
- +45 SET PSOANSQ(PSOX("IRXN"),"SHAD")=$PIECE(ORSCEI,U,8)
- +46 IF '$$PATCH^XPDUTL("OR*3.0*243")
- DO SHAD^PSORN52D
- +47 ;Multi signed Rx's come in consecutively and the diagnosis subscript doesn't start with 1 for each Rx
- SET DX=""
- SET DX2=0
- FOR
- SET DX=$ORDER(ORDX(DX))
- IF DX=""
- QUIT
- SET DX2=DX2+1
- SET PSORX("ICD",DX2)=ORDX(DX)
- +48 ;used in PSORN52D
- SET PSOSCP2=1
- +49 ;
- ICD2 ;Check to see if SC/EI changed during CPRS sign order
- +1 DO GETS^DIQ(52,PSOX("IRXN")_",","52311*","I","PSOOICD")
- +2 SET PSODCPY=0
- SET PSOFLD=""
- +3 FOR TYPE="VEH","RAD","SC>50","PGW","MST","HNC","CV","SHAD"
- IF PSODCPY
- QUIT
- FOR PSOFLD=1:1:8
- Begin DoDot:1
- +4 IF TYPE="VEH"&(PSOFLD=1)
- DO CHOC
- +5 IF TYPE="RAD"&(PSOFLD=2)
- DO CHOC
- +6 IF TYPE="SC>50"&(PSOFLD=3)&($DATA(PSOANSQ(PSOX("IRXN"),TYPE)))
- DO CHOC
- +7 IF TYPE="PGW"&(PSOFLD=4)
- DO CHOC
- +8 IF TYPE="MST"&(PSOFLD=5)
- DO CHOC
- +9 IF TYPE="HNC"&(PSOFLD=6)
- DO CHOC
- +10 IF TYPE="CV"&(PSOFLD=7)
- DO CHOC
- +11 IF TYPE="SHAD"&(PSOFLD=8)
- IF $$PATCH^XPDUTL("OR*3.0*243")
- DO CHOC
- End DoDot:1
- IF PSODCPY
- QUIT
- +12 IF $DATA(PSOANSQ("SC"))
- SET PSOFLD=3
- IF PSOANSQ("SC")'=PSOOICD(52.052311,1_","_PSOX("IRXN")_",",PSOFLD,"I")
- SET PSODCPY=1
- SET PSOFLD=""
- +13 ; 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.
- +14 IF '$GET(PSODCPY)
- Begin DoDot:1
- +15 ;if no ICD's passed and ICD's defined in 52, CPRS overrides OP
- IF '$DATA(PSORX("ICD"))&($GET(PSOOICD(52.052311,1_","_RXN_",",.01,"I")))
- SET PSODGUP=1
- QUIT
- +16 ;get last entry for file 52
- SET (DX3,DX2,DX)=""
- FOR
- SET DX=$ORDER(PSOOICD(52.052311,DX))
- IF DX=""
- QUIT
- SET DX2=+DX
- +17 ;get last entry for new ICD's from CPRS
- SET DX=""
- FOR
- SET DX=$ORDER(PSORX("ICD",DX))
- IF DX=""
- QUIT
- SET DX3=DX
- Begin DoDot:2
- +18 ;if ICD'S changed or more new ICD's than old ones.
- IF $GET(PSOOICD(52.052311,DX_","_PSOX("IRXN")_",",.01,"I"))'=PSORX("ICD",DX)
- SET PSODGUP=1
- End DoDot:2
- +19 ;if more old ICD's than new ones
- IF DX2>DX3
- SET PSODGUP=1
- End DoDot:1
- +20 IF '$GET(PSODCPY)&('$GET(PSODGUP))
- QUIT 1
- +21 ;file SC/EI/ICD'S into Rx file
- DO FILE2^PSORN52D
- +22 ;S PSOCIDC=$P($G(^PSRX(RXN,"ICD",1,0)),"^",2,8)
- +23 ;only do copay if SC/EI changed and SC is less than 50%.
- +24 ;discontinue's no copay changes allowed.
- IF PSODCZ[(","_$GET(PSOSTAZ)_",")
- SET RET="0^6"
- QUIT RET
- +25 ;
- +26 ;Get last fill number
- +27 NEW PSOLFIL
- SET PSOLFIL=$$LF^PSOPFSU1(RXN)
- +28 SET PSOPFS=$PIECE($SELECT('PSOLFIL:$GET(^PSRX(RXN,"PFS")),1:$GET(^PSRX(RXN,1,PSOLFIL,"PFS"))),"^",1,2)
- +29 ; No-copay to copay updates
- +30 SET PSOIBQC=$GET(^PSRX(RXN,"IBQ"))
- SET PSOCICD=$PIECE($GET(^PSRX(RXN,"ICD",1,0)),"^",2,8)
- +31 DO CPAY
- +32 ; 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
- +33 ;don't do no copay to copay bills, but update status
- IF (PSOPIBQ[1&(PSOIBQC'[1))!(PSOIBQC=""&(PSOPICD[1&(PSOCICD'[1)))!($GET(PSODGUP))
- Begin DoDot:1
- +34 DO ALOG
- +35 IF (PSOSCP<50)&($GET(PSODCPY))
- Begin DoDot:2
- +36 IF $PIECE($GET(^PS(53,+$GET(PTSTATUS),0)),"^",7)'=1&('$GET(PSOSI))
- Begin DoDot:3
- +37 IF +$GET(PSOCPAY)<1&($DATA(^PSRX(RXN,"IB")))
- SET $PIECE(^PSRX(RXN,"IB"),"^",1)=""
- +38 IF +$GET(PSOCPAY)>0
- SET $PIECE(^PSRX(RXN,"IB"),"^",1)=+$GET(PSOCPAY)
- SET PSOOLD="No Copay"
- SET PSONW="Copay"
- SET PREA="R"
- SET PSODA=RXN
- IF '$GET(PSOSI)
- DO ACTLOG^PSOCPA
- End DoDot:3
- End DoDot:2
- +39 ;don't send unreleased charge msg
- IF +$GET(PSOPFS)>0&('$PIECE($GET(PSOPFS),"^",2))
- KILL PSOPFS
- QUIT
- +40 ;invalid PFSS ACCT REF/ SEND TO IB
- IF +$GET(PSOPFS)<1
- KILL PSOPFS
- +41 IF +$GET(PSOPFS)>0
- SET PSOPFS="1^"_PSOPFS
- +42 ;
- +43 ;always send to external bill sys
- IF +$GET(PSOPFS)
- DO CHRG^PSOPFSU1(RXN,PSOLFIL,"CG",PSOPFS)
- End DoDot:1
- QUIT RET
- +44 ;
- +45 ; Copay to no-copay updates
- +46 IF $GET(PSODCPY)
- DO COPAY^PSOHLNE4
- +47 ;ICD UPDATE ONLY FOR COPAYS
- +48 ;DIAGNOSIS UPDATE ONLY
- IF ('$GET(PSODCPY)&($GET(PSODGUP)))&($PIECE($GET(PSOPFS),"^",2))
- DO CHRG^PSOPFSU1(RXN,PSOLFIL,"CG",PSOPFS)
- +49 IF ($GET(PSODCPY)!($GET(PSODGUP)))
- DO ALOG
- +50 QUIT RET
- +51 ;
- CPAY ;
- +1 NEW X,Y,III,ACTYP,BL
- +2 SET PSOSITE=$PIECE(^PSRX(RXN,2),"^",9)
- +3 SET X=$PIECE($GET(^PS(59,+PSOSITE,"IB")),"^")_"^"_DFN
- DO XTYPE^IBARX
- +4 SET (ACTYP,BL)=""
- SET (PSOBILL,PSOCPAY)=0
- CPAY1 ;
- +1 SET ACTYP=$ORDER(Y(ACTYP))
- IF 'ACTYP
- GOTO CSKP
- FOR III=0:0
- SET BL=$ORDER(Y(ACTYP,BL))
- IF BL=""
- QUIT
- IF BL>0
- SET PSOBILL=BL
- SET PSOCPAY=BL_"^"_Y(ACTYP,BL)
- +2 GOTO CPAY1
- CSKP ;
- +1 ;Supply item/investigational drug/nutritional supplement
- IF $GET(PSOSI)
- SET PSOCPAY=0
- +2 ;Rx Patient Status exempt
- IF $PIECE($GET(^PS(53,+$GET(PTSTATUS),0)),"^",7)=1
- SET PSOCPAY=0
- +3 ;Yes SC/EI from CPRS
- IF PSOIBQC'=""
- IF PSOIBQC'[1
- SET PSOCPAY=1
- +4 ;INELIGIBLE
- IF (PSOBILL'>0)!(PSOCPAY=0)
- SET PSOCPAY=0
- +5 QUIT
- +6 ;
- CHOC ;check outpatient classifications
- +1 IF PSOANSQ(PSOX("IRXN"),TYPE)'=PSOOICD(52.052311,1_","_PSOX("IRXN")_",",PSOFLD,"I")
- SET PSODCPY=1
- +2 QUIT
- +3 ;
- ALOG ;set activity log with edit info from cprs
- +1 NEW ACNT,SUB,RF,RFCNT
- +2 SET ACNT=0
- FOR SUB=0:0
- SET SUB=$ORDER(^PSRX(RXN,"A",SUB))
- IF 'SUB
- QUIT
- SET ACNT=SUB
- +3 SET RFCNT=0
- FOR RF=0:0
- SET RF=$ORDER(^PSRX(RXN,1,RF))
- IF 'RF
- QUIT
- SET RFCNT=RF
- IF RF>5
- SET RFCNT=RF+1
- +4 DO NOW^%DTC
- SET ACNT=ACNT+1
- +5 SET ^PSRX(RXN,"A",0)="^52.3DA^"_ACNT_"^"_ACNT
- SET ^PSRX(RXN,"A",ACNT,0)=%_"^"_"E"_"^^"_RFCNT_"^Clinical Indicators and SC/EI's were updated from a CPRS e-sig edit at "_$EXTRACT($PIECE(%,".",2),1,2)_":"_$EXTRACT($PIECE(%,".",2),3,4)_"."
- +6 QUIT
- +7 ;
- CHKOI ;get and compare orderable items in file #100 and #52; don't process
- +1 ; if it's different and the placer # is null.
- +2 IF '$DATA(ARRAY(52,RXN_",",6,"I"))
- SET OICHK=1
- QUIT
- +3 DO GETS^DIQ(50,ARRAY(52,RXN_",",6,"I")_",","2.1","I","PSOOI")
- +4 SET ORITEM2=$$GET1^DIQ(100.001,"1,"_ORIEN_",",".01","I")
- +5 SET ORID=$$GET1^DIQ(101.43,ORITEM2_",","2","I")
- SET ORID=$PIECE(ORID,";",1)
- +6 IF PSOOI(50,ARRAY(52,RXN_",",6,"I")_",",2.1,"I")'=""
- IF PSOOI(50,ARRAY(52,RXN_",",6,"I")_",",2.1,"I")'=ORID
- SET OICHK=1
- +7 QUIT
- TEST(ORIEN) ;manually test an individual order record
- +1 NEW I,X,ORSCEIS,ORSCEI,ORDX,EDFLG,ORITEM,DFN,JJ
- +2 SET (JJ,I)=0
- FOR
- SET I=$ORDER(^OR(100,ORIEN,5.1,I))
- IF I=""!(I'?1N.NN)
- QUIT
- SET JJ=JJ+1
- SET ORDX(JJ)=$GET(^OR(100,ORIEN,5.1,I,0))
- +3 SET ORSCEIS=^OR(100,ORIEN,5.2)
- SET ORITEM=$PIECE($GET(^OR(100,ORIEN,4)),"^",1)
- +4 SET ORSCEI=""
- FOR I=3,4,1,5,2,6,7
- SET ORSCEI=ORSCEI_"^"_$PIECE(ORSCEIS,"^",I)
- +5 IF $$PATCH^XPDUTL("OR*3.0*243")
- SET ORSCEI=ORSCEI_"^"_$PIECE(ORSCEIS,"^",8)
- +6 SET ORSCEI=$EXTRACT(ORSCEI,2,99)
- +7 SET RXN=ORITEM
- SET DFN=$PIECE($PIECE(^OR(100,ORIEN,0),"^",2),";",1)
- +8 DO EN^PSOHLNE3(DFN,ORITEM,ORIEN,.ORDX,ORSCEI)
- +9 QUIT
- OBXNTE ; Called from PSOHLNEW due to it's routine size.
- +1 SET LL=ZZ+1
- SET PSOBCT=2
- +2 IF $PIECE($GET(MSG(LL)),"|")="NTE"
- Begin DoDot:1
- +3 IF $PIECE(MSG(LL),"|",4)'=""
- SET PSOBCT=3
- SET OBXAR(OCOUNT,2)=$PIECE(MSG(LL),"|",4)
- +4 FOR LLL=0:0
- SET LLL=$ORDER(MSG(LL,LLL))
- IF 'LLL
- QUIT
- Begin DoDot:2
- +5 IF $PIECE($GET(MSG(LL,LLL)),"|",4)'=""
- SET OBXAR(OCOUNT,PSOBCT)=$PIECE(MSG(LL,LLL),"|",4)
- SET PSOBCT=PSOBCT+1
- End DoDot:2
- End DoDot:1
- +6 QUIT
