ORWDPS4 ;; SLC/JDL - Order Dialogs CO-PAY and Other;[12/31/01 6:38pm]
;;3.0;ORDER ENTRY/RESULTS REPORTING;**116,125,131,141,173,187,190,195,215,243**;Dec 17, 1997;Build 242
;
CPLST(TEST,PTIFN,ORIFNS) ; --Get CP questions
N ORIFN,ORDA,ORI,ORPSO,CPX
S ORI=0,ORPSO=+$O(^DIC(9.4,"C","PSO",0))
F S ORI=$O(ORIFNS(ORI)) Q:'ORI D
.S ORIFN=+ORIFNS(ORI),ORDA=$P(ORIFNS(ORI),";",2)
.I $D(^OR(100,ORIFN,0)),($P(^OR(100,ORIFN,0),U,14)=ORPSO) D
..N PRIO S PRIO=0
..I $D(^OR(100,ORIFN,4.5,"ID","URGENCY")) S PRIO=$O(^("URGENCY",0))
..S PRIO=$G(^OR(100,ORIFN,4.5,+PRIO,1))
..Q:PRIO=99
..S CPX=$$SC(ORIFN)
..I $L(CPX)>1 S TEST(ORIFN)=ORIFN_";"_ORDA_CPX
K PTIFN,ORIFN,ORDA,ORI,CPX
Q
;
CPINFO(Y,ORINFO) ; -- Save reponses to CP questions
Q:'$D(ORINFO)
N ORIFN,ORI,ORX,ANS S ORI=0
F S ORI=$O(ORINFO(ORI)) Q:'ORI D
.S ORIFN=$P($P(ORINFO(ORI),U,1),";",1)
.S ANS=$P(ORINFO(ORI),U,2)
.D REFMT(.ORX,ANS)
.D SC^ORCSAVE2(.ORX,ORIFN)
S Y=1
K ORIFN,ORX,ORI,ANS
Q
;
SC(ORIFN) ; -- Dialog validation, to ask CP questions
;Expects ORIFN and ORDA
;
N DR S DR=""
I '$L($T(SCNEW^PSOCP))!('$G(ORIFN))!('$G(ORDA)) Q DR
I $P($G(^OR(100,ORIFN,8,ORDA,0)),U,2)'="NW" Q DR
;
N OR3,ORDRUG,ORENEW,ORX,I,XACT,YACT,CPNODE,ASC,AAO,AIR,AEC,AMST,AHNC,ACV,ASHD
S ORX="",XACT=""
;--Only new, renew, edited, copied outpatient order can continue...
;AGP CHANGE 26.65, will returned service connection data for change orders
S OR3=$G(^OR(100,ORIFN,3)),XACT=$P(OR3,U,11) I (XACT'=0)&(XACT'=1)&((XACT'=2)&(XACT'="C")) Q DR
I (XACT=1)&($D(^OR(100,ORIFN,5))=0) Q DR
I $D(^OR(100,ORIFN,5))>0 D
.S CPNODE=$G(^OR(100,ORIFN,5))
.S ASC=$S($L($P(CPNODE,"^",1)):"SC;"_$P(CPNODE,"^",1),1:"")
.S DR=$S($L(ASC):DR_U_ASC,1:DR)
.S AAO=$S($L($P(CPNODE,"^",3)):"AO;"_$P(CPNODE,"^",3),1:"")
.S DR=$S($L(AAO):DR_U_AAO,1:DR)
.S AIR=$S($L($P(CPNODE,"^",4)):"IR;"_$P(CPNODE,"^",4),1:"")
.S DR=$S($L(AIR):DR_U_AIR,1:DR)
.S AEC=$S($L($P(CPNODE,"^",5)):"EC;"_$P(CPNODE,"^",5),1:"")
.S DR=$S($L(AEC):DR_U_AEC,1:DR)
.S AMST=$S($L($P(CPNODE,"^",2)):"MST;"_$P(CPNODE,"^",2),1:"")
.S DR=$S($L(AMST):DR_U_AMST,1:DR)
.S AHNC=$S($L($P(CPNODE,"^",6)):"HNC;"_$P(CPNODE,"^",6),1:"")
.S DR=$S($L(AHNC):DR_U_AHNC,1:DR)
.S ACV=$S($L($P(CPNODE,"^",7)):"CV;"_$P(CPNODE,"^",7),1:"")
.S DR=$S($L(ACV):DR_U_ACV,1:DR)
.S ASHD=$S($L($P(CPNODE,"^",8)):"SHD;"_$P(CPNODE,"^",8),1:"")
.S DR=$S($L(ASHD):DR_U_ASHD,1:DR)
.D CPCOMP(.DR)
.K ASC,AAO,AIR,AEC,AMST,AHNC,CPNODE
I $L(DR)>0 Q DR
I XACT=2 S YACT=$P(OR3,U,5),ORENEW=$G(^OR(100,YACT,4)) ;get PS# if renewal
S ORDRUG=$$VALUE^ORCSAVE2(ORIFN,"DRUG")
D SCNEW^PSOCP(.ORX,+PTIFN,ORDRUG,$G(ORENEW)) I '$D(ORX) Q DR
F I="SC","AO","IR","EC","MST","HNC","CV","SHD" D
. I $D(ORX(I)) S DR=DR_U_I_$S($L(ORX(I)):";"_ORX(I),1:"")
Q DR
REFMT(ORX,INFO) ;
;"U": Unchecked ("NO")
;"C": Checked ("YES")
;"N" : Question not asked
N RST,RST1
S RST=""
F I=1:1:$L(INFO) S RST=RST_U_$S($E(INFO,I)="U":0,$E(INFO,I)="C":1,1:"")
S RST1=$E(RST,2,$L(RST))
S ORX("SC")=$P(RST1,U,1)
S ORX("MST")=$P(RST1,U,5)
S ORX("AO")=$P(RST1,U,2)
S ORX("IR")=$P(RST1,U,3)
S ORX("EC")=$P(RST1,U,4)
S ORX("HNC")=$P(RST1,U,6)
S ORX("CV")=$P(RST1,U,7)
S ORX("SHD")=$P(RST1,U,8)
K RST,RST1
Q
CPCOMP(PREX) ; -- Compare the existed exemptions with new exemption questions
N ORX1,ORDRUG1,CPI,LSTCP,TMPVAL
S LSTCP=""
S ORDRUG1=$$VALUE^ORCSAVE2(ORIFN,"DRUG")
D SCNEW^PSOCP(.ORX1,+PTIFN,ORDRUG1,$G(ORENEW)) I '$D(ORX1) Q
F CPI="SC","AO","IR","EC","MST","HNC","CV","SHD" D
. I $D(ORX1(CPI)) D
. . S TMPVAL=""
. . I $F(PREX,CPI) D
. . . S TMPVAL=+$E(PREX,$F(PREX,CPI)+1)
. . . I $L(TMPVAL),((TMPVAL=0)!(TMPVAL=1)) S TMPVAL=CPI_";"_TMPVAL
. . . E S TMPVAL=CPI
. . E S TMPVAL=CPI
. . S LSTCP=LSTCP_U_TMPVAL
S PREX=LSTCP
Q
IPOD4OP(ORY,ORID) ;True: is an Inpt (IV OI) order on an OutPatient
Q:'$D(^OR(100,+ORID,0))
S ORY=0
N APKG,ADLG,ADG,APTCLS,RXDG,UDDLG,IPPKG
S (RXDG,UDDLG,IPPKG)=0
S RXDG=+$O(^ORD(100.98,"B","O RX",0))
S UDDLG=+$O(^ORD(101.41,"B","PSJ OR PAT OE",0))
S IPPKG=+$O(^DIC(9.4,"B","INPATIENT MEDICATIONS",0))
S ADLG=+$P($G(^OR(100,+ORID,0)),U,5)
S ADG=$P($G(^OR(100,+ORID,0)),U,11)
S APKG=$P($G(^OR(100,+ORID,0)),U,14)
S APTCLS=$P($G(^OR(100,+ORID,0)),U,12)
I ADG=RXDG,(ADLG=UDDLG),(APKG=IPPKG),(APTCLS="I") S ORY=1
Q
;
UPDTDG(ORY,ORID) ;Update Inpt order for outpatient DG to Inpt DG
Q:'$D(^OR(100,+ORID,0))
N UDDG
S UDDG=$O(^ORD(100.98,"B","UD RX",0))
S $P(^OR(100,+ORID,0),U,11)=UDDG
Q
ISUDIV(ORY,ORIFN) ;True: OI of the order is for both UD and IV
N OI
S (OI,ORY)=0
S OI=+$O(^OR(100,+$G(ORIFN),.1,"B",0)) Q:OI<1
I $O(^ORD(101.43,OI,9,"B","IVM RX",0)) S ORY=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWDPS4 4729 printed Sep 23, 2025@20:12:04 Page 2
ORWDPS4 ;; SLC/JDL - Order Dialogs CO-PAY and Other;[12/31/01 6:38pm]
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**116,125,131,141,173,187,190,195,215,243**;Dec 17, 1997;Build 242
+2 ;
CPLST(TEST,PTIFN,ORIFNS) ; --Get CP questions
+1 NEW ORIFN,ORDA,ORI,ORPSO,CPX
+2 SET ORI=0
SET ORPSO=+$ORDER(^DIC(9.4,"C","PSO",0))
+3 FOR
SET ORI=$ORDER(ORIFNS(ORI))
if 'ORI
QUIT
Begin DoDot:1
+4 SET ORIFN=+ORIFNS(ORI)
SET ORDA=$PIECE(ORIFNS(ORI),";",2)
+5 IF $DATA(^OR(100,ORIFN,0))
IF ($PIECE(^OR(100,ORIFN,0),U,14)=ORPSO)
Begin DoDot:2
+6 NEW PRIO
SET PRIO=0
+7 IF $DATA(^OR(100,ORIFN,4.5,"ID","URGENCY"))
SET PRIO=$ORDER(^("URGENCY",0))
+8 SET PRIO=$GET(^OR(100,ORIFN,4.5,+PRIO,1))
+9 if PRIO=99
QUIT
+10 SET CPX=$$SC(ORIFN)
+11 IF $LENGTH(CPX)>1
SET TEST(ORIFN)=ORIFN_";"_ORDA_CPX
End DoDot:2
End DoDot:1
+12 KILL PTIFN,ORIFN,ORDA,ORI,CPX
+13 QUIT
+14 ;
CPINFO(Y,ORINFO) ; -- Save reponses to CP questions
+1 if '$DATA(ORINFO)
QUIT
+2 NEW ORIFN,ORI,ORX,ANS
SET ORI=0
+3 FOR
SET ORI=$ORDER(ORINFO(ORI))
if 'ORI
QUIT
Begin DoDot:1
+4 SET ORIFN=$PIECE($PIECE(ORINFO(ORI),U,1),";",1)
+5 SET ANS=$PIECE(ORINFO(ORI),U,2)
+6 DO REFMT(.ORX,ANS)
+7 DO SC^ORCSAVE2(.ORX,ORIFN)
End DoDot:1
+8 SET Y=1
+9 KILL ORIFN,ORX,ORI,ANS
+10 QUIT
+11 ;
SC(ORIFN) ; -- Dialog validation, to ask CP questions
+1 ;Expects ORIFN and ORDA
+2 ;
+3 NEW DR
SET DR=""
+4 IF '$LENGTH($TEXT(SCNEW^PSOCP))!('$GET(ORIFN))!('$GET(ORDA))
QUIT DR
+5 IF $PIECE($GET(^OR(100,ORIFN,8,ORDA,0)),U,2)'="NW"
QUIT DR
+6 ;
+7 NEW OR3,ORDRUG,ORENEW,ORX,I,XACT,YACT,CPNODE,ASC,AAO,AIR,AEC,AMST,AHNC,ACV,ASHD
+8 SET ORX=""
SET XACT=""
+9 ;--Only new, renew, edited, copied outpatient order can continue...
+10 ;AGP CHANGE 26.65, will returned service connection data for change orders
+11 SET OR3=$GET(^OR(100,ORIFN,3))
SET XACT=$PIECE(OR3,U,11)
IF (XACT'=0)&(XACT'=1)&((XACT'=2)&(XACT'="C"))
QUIT DR
+12 IF (XACT=1)&($DATA(^OR(100,ORIFN,5))=0)
QUIT DR
+13 IF $DATA(^OR(100,ORIFN,5))>0
Begin DoDot:1
+14 SET CPNODE=$GET(^OR(100,ORIFN,5))
+15 SET ASC=$SELECT($LENGTH($PIECE(CPNODE,"^",1)):"SC;"_$PIECE(CPNODE,"^",1),1:"")
+16 SET DR=$SELECT($LENGTH(ASC):DR_U_ASC,1:DR)
+17 SET AAO=$SELECT($LENGTH($PIECE(CPNODE,"^",3)):"AO;"_$PIECE(CPNODE,"^",3),1:"")
+18 SET DR=$SELECT($LENGTH(AAO):DR_U_AAO,1:DR)
+19 SET AIR=$SELECT($LENGTH($PIECE(CPNODE,"^",4)):"IR;"_$PIECE(CPNODE,"^",4),1:"")
+20 SET DR=$SELECT($LENGTH(AIR):DR_U_AIR,1:DR)
+21 SET AEC=$SELECT($LENGTH($PIECE(CPNODE,"^",5)):"EC;"_$PIECE(CPNODE,"^",5),1:"")
+22 SET DR=$SELECT($LENGTH(AEC):DR_U_AEC,1:DR)
+23 SET AMST=$SELECT($LENGTH($PIECE(CPNODE,"^",2)):"MST;"_$PIECE(CPNODE,"^",2),1:"")
+24 SET DR=$SELECT($LENGTH(AMST):DR_U_AMST,1:DR)
+25 SET AHNC=$SELECT($LENGTH($PIECE(CPNODE,"^",6)):"HNC;"_$PIECE(CPNODE,"^",6),1:"")
+26 SET DR=$SELECT($LENGTH(AHNC):DR_U_AHNC,1:DR)
+27 SET ACV=$SELECT($LENGTH($PIECE(CPNODE,"^",7)):"CV;"_$PIECE(CPNODE,"^",7),1:"")
+28 SET DR=$SELECT($LENGTH(ACV):DR_U_ACV,1:DR)
+29 SET ASHD=$SELECT($LENGTH($PIECE(CPNODE,"^",8)):"SHD;"_$PIECE(CPNODE,"^",8),1:"")
+30 SET DR=$SELECT($LENGTH(ASHD):DR_U_ASHD,1:DR)
+31 DO CPCOMP(.DR)
+32 KILL ASC,AAO,AIR,AEC,AMST,AHNC,CPNODE
End DoDot:1
+33 IF $LENGTH(DR)>0
QUIT DR
+34 ;get PS# if renewal
IF XACT=2
SET YACT=$PIECE(OR3,U,5)
SET ORENEW=$GET(^OR(100,YACT,4))
+35 SET ORDRUG=$$VALUE^ORCSAVE2(ORIFN,"DRUG")
+36 DO SCNEW^PSOCP(.ORX,+PTIFN,ORDRUG,$GET(ORENEW))
IF '$DATA(ORX)
QUIT DR
+37 FOR I="SC","AO","IR","EC","MST","HNC","CV","SHD"
Begin DoDot:1
+38 IF $DATA(ORX(I))
SET DR=DR_U_I_$SELECT($LENGTH(ORX(I)):";"_ORX(I),1:"")
End DoDot:1
+39 QUIT DR
REFMT(ORX,INFO) ;
+1 ;"U": Unchecked ("NO")
+2 ;"C": Checked ("YES")
+3 ;"N" : Question not asked
+4 NEW RST,RST1
+5 SET RST=""
+6 FOR I=1:1:$LENGTH(INFO)
SET RST=RST_U_$SELECT($EXTRACT(INFO,I)="U":0,$EXTRACT(INFO,I)="C":1,1:"")
+7 SET RST1=$EXTRACT(RST,2,$LENGTH(RST))
+8 SET ORX("SC")=$PIECE(RST1,U,1)
+9 SET ORX("MST")=$PIECE(RST1,U,5)
+10 SET ORX("AO")=$PIECE(RST1,U,2)
+11 SET ORX("IR")=$PIECE(RST1,U,3)
+12 SET ORX("EC")=$PIECE(RST1,U,4)
+13 SET ORX("HNC")=$PIECE(RST1,U,6)
+14 SET ORX("CV")=$PIECE(RST1,U,7)
+15 SET ORX("SHD")=$PIECE(RST1,U,8)
+16 KILL RST,RST1
+17 QUIT
CPCOMP(PREX) ; -- Compare the existed exemptions with new exemption questions
+1 NEW ORX1,ORDRUG1,CPI,LSTCP,TMPVAL
+2 SET LSTCP=""
+3 SET ORDRUG1=$$VALUE^ORCSAVE2(ORIFN,"DRUG")
+4 DO SCNEW^PSOCP(.ORX1,+PTIFN,ORDRUG1,$GET(ORENEW))
IF '$DATA(ORX1)
QUIT
+5 FOR CPI="SC","AO","IR","EC","MST","HNC","CV","SHD"
Begin DoDot:1
+6 IF $DATA(ORX1(CPI))
Begin DoDot:2
+7 SET TMPVAL=""
+8 IF $FIND(PREX,CPI)
Begin DoDot:3
+9 SET TMPVAL=+$EXTRACT(PREX,$FIND(PREX,CPI)+1)
+10 IF $LENGTH(TMPVAL)
IF ((TMPVAL=0)!(TMPVAL=1))
SET TMPVAL=CPI_";"_TMPVAL
+11 IF '$TEST
SET TMPVAL=CPI
End DoDot:3
+12 IF '$TEST
SET TMPVAL=CPI
+13 SET LSTCP=LSTCP_U_TMPVAL
End DoDot:2
End DoDot:1
+14 SET PREX=LSTCP
+15 QUIT
IPOD4OP(ORY,ORID) ;True: is an Inpt (IV OI) order on an OutPatient
+1 if '$DATA(^OR(100,+ORID,0))
QUIT
+2 SET ORY=0
+3 NEW APKG,ADLG,ADG,APTCLS,RXDG,UDDLG,IPPKG
+4 SET (RXDG,UDDLG,IPPKG)=0
+5 SET RXDG=+$ORDER(^ORD(100.98,"B","O RX",0))
+6 SET UDDLG=+$ORDER(^ORD(101.41,"B","PSJ OR PAT OE",0))
+7 SET IPPKG=+$ORDER(^DIC(9.4,"B","INPATIENT MEDICATIONS",0))
+8 SET ADLG=+$PIECE($GET(^OR(100,+ORID,0)),U,5)
+9 SET ADG=$PIECE($GET(^OR(100,+ORID,0)),U,11)
+10 SET APKG=$PIECE($GET(^OR(100,+ORID,0)),U,14)
+11 SET APTCLS=$PIECE($GET(^OR(100,+ORID,0)),U,12)
+12 IF ADG=RXDG
IF (ADLG=UDDLG)
IF (APKG=IPPKG)
IF (APTCLS="I")
SET ORY=1
+13 QUIT
+14 ;
UPDTDG(ORY,ORID) ;Update Inpt order for outpatient DG to Inpt DG
+1 if '$DATA(^OR(100,+ORID,0))
QUIT
+2 NEW UDDG
+3 SET UDDG=$ORDER(^ORD(100.98,"B","UD RX",0))
+4 SET $PIECE(^OR(100,+ORID,0),U,11)=UDDG
+5 QUIT
ISUDIV(ORY,ORIFN) ;True: OI of the order is for both UD and IV
+1 NEW OI
+2 SET (OI,ORY)=0
+3 SET OI=+$ORDER(^OR(100,+$GET(ORIFN),.1,"B",0))
if OI<1
QUIT
+4 IF $ORDER(^ORD(101.43,OI,9,"B","IVM RX",0))
SET ORY=1
+5 QUIT
