PSOHLNE3 ;BIR/LE - Process Edit Information from CPRS ;02/27/04
;;7.0;OUTPATIENT PHARMACY;**143,239,201,225,303,460,476**;DEC 1997;Build 35
;External reference to ^OR(100 private DBIA 2219
;External reference to $$CPTIER^PSNAPIS(P1,P3) supported by DBIA #2531
;External reference to IBARX supported by DBIA #125
;
;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,PSOCOMM
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 ;
N PSOEXMPT
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,PSOEXMPT=1 ;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
;***** begin - for regression test - sites must not use this as it will adversely affect billing results - only used by SQA
; The following is required for testing different effective dates. If date is less than 02/27/17 bills old way. Otherwise bills new way.
;S ^XTMP("PSOTIEREFTST",0)="3201231^3170227^FOR SQA TESTING ONLY" - Defined for SQA testing only. Delete this XTMP when regression complete
D NOW^%DTC N PSOTIERE
S PSOTIERE=1 ;use copay tiers - new
I $P(%,".")<3170227 S PSOTIERE=0 ;legacy billing - old
I $G(^XTMP("PSOTIEREFTST",0)) S PSOTIERE=1 ;for SQA testing only - bill with copay tiers - new
;***** end for regression test
G COPAYRE1:'PSOTIERE
; check copay tier. Tier zero does not have copay charges
N CPDATE,X,PSOCPT D NOW^%DTC S CPDATE=X S PSOCPT=$$CPTIER^PSNAPIS("",CPDATE,DRG) K CPDATE,X
I $P(PSOCPT,"^")=0 S PSOCPAY=0,$P(^PSRX(RXN,"IB"),"^",1)="" ;Tier zero do not send to IB for copay charge
I '$G(PSOEXMPT),$P(PSOCPT,"^")'=0 S PSOCPAY=1
COPAYRE1 ;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOHLNE3 10608 printed Apr 09, 2024@21:29:20 Page 2
PSOHLNE3 ;BIR/LE - Process Edit Information from CPRS ;02/27/04
+1 ;;7.0;OUTPATIENT PHARMACY;**143,239,201,225,303,460,476**;DEC 1997;Build 35
+2 ;External reference to ^OR(100 private DBIA 2219
+3 ;External reference to $$CPTIER^PSNAPIS(P1,P3) supported by DBIA #2531
+4 ;External reference to IBARX supported by DBIA #125
+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 ;
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,PSOCOMM
+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 NEW PSOEXMPT
+2 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)
+3 GOTO CPAY1
CSKP ;
+1 ;Supply item/investigational drug/nutritional supplement
if $GET(PSOSI)
SET PSOCPAY=0
SET PSOEXMPT=1
+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 ;***** begin - for regression test - sites must not use this as it will adversely affect billing results - only used by SQA
+6 ; The following is required for testing different effective dates. If date is less than 02/27/17 bills old way. Otherwise bills new way.
+7 ;S ^XTMP("PSOTIEREFTST",0)="3201231^3170227^FOR SQA TESTING ONLY" - Defined for SQA testing only. Delete this XTMP when regression complete
+8 DO NOW^%DTC
NEW PSOTIERE
+9 ;use copay tiers - new
SET PSOTIERE=1
+10 ;legacy billing - old
IF $PIECE(%,".")<3170227
SET PSOTIERE=0
+11 ;for SQA testing only - bill with copay tiers - new
IF $GET(^XTMP("PSOTIEREFTST",0))
SET PSOTIERE=1
+12 ;***** end for regression test
+13 if 'PSOTIERE
GOTO COPAYRE1
+14 ; check copay tier. Tier zero does not have copay charges
+15 NEW CPDATE,X,PSOCPT
DO NOW^%DTC
SET CPDATE=X
SET PSOCPT=$$CPTIER^PSNAPIS("",CPDATE,DRG)
KILL CPDATE,X
+16 ;Tier zero do not send to IB for copay charge
IF $PIECE(PSOCPT,"^")=0
SET PSOCPAY=0
SET $PIECE(^PSRX(RXN,"IB"),"^",1)=""
+17 IF '$GET(PSOEXMPT)
IF $PIECE(PSOCPT,"^")'=0
SET PSOCPAY=1
COPAYRE1 ;
+1 QUIT
+2 ;
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
