- Timestamp:
- Dec 4, 2009, 12:11:15 AM (15 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDPS4.m
r613 r623 1 ORWDPS4 ;; SLC/JDL - Order Dialogs CO-PAY and Other;[12/31/01 6:38pm] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**116,125,131,141,173,187,190,195,215,243**;Dec 17, 1997;Build 242 3 ; 4 CPLST(TEST,PTIFN,ORIFNS) ; --Get CP questions 5 N ORIFN,ORDA,ORI,ORPSO,CPX 6 S ORI=0,ORPSO=+$O(^DIC(9.4,"C","PSO",0)) 7 F S ORI=$O(ORIFNS(ORI)) Q:'ORI D 8 .S ORIFN=+ORIFNS(ORI),ORDA=$P(ORIFNS(ORI),";",2) 9 .I $D(^OR(100,ORIFN,0)),($P(^OR(100,ORIFN,0),U,14)=ORPSO) D 10 ..N PRIO S PRIO=0 11 ..I $D(^OR(100,ORIFN,4.5,"ID","URGENCY")) S PRIO=$O(^("URGENCY",0)) 12 ..S PRIO=$G(^OR(100,ORIFN,4.5,+PRIO,1)) 13 ..Q:PRIO=99 14 ..S CPX=$$SC(ORIFN) 15 ..I $L(CPX)>1 S TEST(ORIFN)=ORIFN_";"_ORDA_CPX 16 K PTIFN,ORIFN,ORDA,ORI,CPX 17 Q 18 ; 19 CPINFO(Y,ORINFO) ; -- Save reponses to CP questions 20 Q:'$D(ORINFO) 21 N ORIFN,ORI,ORX,ANS S ORI=0 22 F S ORI=$O(ORINFO(ORI)) Q:'ORI D 23 .S ORIFN=$P($P(ORINFO(ORI),U,1),";",1) 24 .S ANS=$P(ORINFO(ORI),U,2) 25 .D REFMT(.ORX,ANS) 26 .D SC^ORCSAVE2(.ORX,ORIFN) 27 S Y=1 28 K ORIFN,ORX,ORI,ANS 29 Q 30 ; 31 SC(ORIFN) ; -- Dialog validation, to ask CP questions 32 ;Expects ORIFN and ORDA 33 ; 34 N DR S DR="" 35 I '$L($T(SCNEW^PSOCP))!('$G(ORIFN))!('$G(ORDA)) Q DR 36 I $P($G(^OR(100,ORIFN,8,ORDA,0)),U,2)'="NW" Q DR 37 ; 38 N OR3,ORDRUG,ORENEW,ORX,I,XACT,YACT,CPNODE,ASC,AAO,AIR,AEC,AMST,AHNC,ACV,ASHD 39 S ORX="",XACT="" 40 ;--Only new, renew, edited, copied outpatient order can continue... 41 ;AGP CHANGE 26.65, will returned service connection data for change orders 42 S OR3=$G(^OR(100,ORIFN,3)),XACT=$P(OR3,U,11) I (XACT'=0)&(XACT'=1)&((XACT'=2)&(XACT'="C")) Q DR 43 I (XACT=1)&($D(^OR(100,ORIFN,5))=0) Q DR 44 I $D(^OR(100,ORIFN,5))>0 D 45 .S CPNODE=$G(^OR(100,ORIFN,5)) 46 .S ASC=$S($L($P(CPNODE,"^",1)):"SC;"_$P(CPNODE,"^",1),1:"") 47 .S DR=$S($L(ASC):DR_U_ASC,1:DR) 48 .S AAO=$S($L($P(CPNODE,"^",3)):"AO;"_$P(CPNODE,"^",3),1:"") 49 .S DR=$S($L(AAO):DR_U_AAO,1:DR) 50 .S AIR=$S($L($P(CPNODE,"^",4)):"IR;"_$P(CPNODE,"^",4),1:"") 51 .S DR=$S($L(AIR):DR_U_AIR,1:DR) 52 .S AEC=$S($L($P(CPNODE,"^",5)):"EC;"_$P(CPNODE,"^",5),1:"") 53 .S DR=$S($L(AEC):DR_U_AEC,1:DR) 54 .S AMST=$S($L($P(CPNODE,"^",2)):"MST;"_$P(CPNODE,"^",2),1:"") 55 .S DR=$S($L(AMST):DR_U_AMST,1:DR) 56 .S AHNC=$S($L($P(CPNODE,"^",6)):"HNC;"_$P(CPNODE,"^",6),1:"") 57 .S DR=$S($L(AHNC):DR_U_AHNC,1:DR) 58 .S ACV=$S($L($P(CPNODE,"^",7)):"CV;"_$P(CPNODE,"^",7),1:"") 59 .S DR=$S($L(ACV):DR_U_ACV,1:DR) 60 .S ASHD=$S($L($P(CPNODE,"^",8)):"SHD;"_$P(CPNODE,"^",8),1:"") 61 .S DR=$S($L(ASHD):DR_U_ASHD,1:DR) 62 .D CPCOMP(.DR) 63 .K ASC,AAO,AIR,AEC,AMST,AHNC,CPNODE 64 I $L(DR)>0 Q DR 65 I XACT=2 S YACT=$P(OR3,U,5),ORENEW=$G(^OR(100,YACT,4)) ;get PS# if renewal 66 S ORDRUG=$$VALUE^ORCSAVE2(ORIFN,"DRUG") 67 D SCNEW^PSOCP(.ORX,+PTIFN,ORDRUG,$G(ORENEW)) I '$D(ORX) Q DR 68 F I="SC","AO","IR","EC","MST","HNC","CV","SHD" D 69 . I $D(ORX(I)) S DR=DR_U_I_$S($L(ORX(I)):";"_ORX(I),1:"") 70 Q DR 71 REFMT(ORX,INFO) ; 72 ;"U": Unchecked ("NO") 73 ;"C": Checked ("YES") 74 ;"N" : Question not asked 75 N RST,RST1 76 S RST="" 77 F I=1:1:$L(INFO) S RST=RST_U_$S($E(INFO,I)="U":0,$E(INFO,I)="C":1,1:"") 78 S RST1=$E(RST,2,$L(RST)) 79 S ORX("SC")=$P(RST1,U,1) 80 S ORX("MST")=$P(RST1,U,5) 81 S ORX("AO")=$P(RST1,U,2) 82 S ORX("IR")=$P(RST1,U,3) 83 S ORX("EC")=$P(RST1,U,4) 84 S ORX("HNC")=$P(RST1,U,6) 85 S ORX("CV")=$P(RST1,U,7) 86 S ORX("SHD")=$P(RST1,U,8) 87 K RST,RST1 88 Q 89 CPCOMP(PREX) ; -- Compare the existed exemptions with new exemption questions 90 N ORX1,ORDRUG1,CPI,LSTCP,TMPVAL 91 S LSTCP="" 92 S ORDRUG1=$$VALUE^ORCSAVE2(ORIFN,"DRUG") 93 D SCNEW^PSOCP(.ORX1,+PTIFN,ORDRUG1,$G(ORENEW)) I '$D(ORX1) Q 94 F CPI="SC","AO","IR","EC","MST","HNC","CV","SHD" D 95 . I $D(ORX1(CPI)) D 96 . . S TMPVAL="" 97 . . I $F(PREX,CPI) D 98 . . . S TMPVAL=+$E(PREX,$F(PREX,CPI)+1) 99 . . . I $L(TMPVAL),((TMPVAL=0)!(TMPVAL=1)) S TMPVAL=CPI_";"_TMPVAL 100 . . . E S TMPVAL=CPI 101 . . E S TMPVAL=CPI 102 . . S LSTCP=LSTCP_U_TMPVAL 103 S PREX=LSTCP 104 Q 105 IPOD4OP(ORY,ORID) ;True: is an Inpt (IV OI) order on an OutPatient 106 Q:'$D(^OR(100,+ORID,0)) 107 S ORY=0 108 N APKG,ADLG,ADG,APTCLS,RXDG,UDDLG,IPPKG 109 S (RXDG,UDDLG,IPPKG)=0 110 S RXDG=+$O(^ORD(100.98,"B","O RX",0)) 111 S UDDLG=+$O(^ORD(101.41,"B","PSJ OR PAT OE",0)) 112 S IPPKG=+$O(^DIC(9.4,"B","INPATIENT MEDICATIONS",0)) 113 S ADLG=+$P($G(^OR(100,+ORID,0)),U,5) 114 S ADG=$P($G(^OR(100,+ORID,0)),U,11) 115 S APKG=$P($G(^OR(100,+ORID,0)),U,14) 116 S APTCLS=$P($G(^OR(100,+ORID,0)),U,12) 117 I ADG=RXDG,(ADLG=UDDLG),(APKG=IPPKG),(APTCLS="I") S ORY=1 118 Q 119 ; 120 UPDTDG(ORY,ORID) ;Update Inpt order for outpatient DG to Inpt DG 121 Q:'$D(^OR(100,+ORID,0)) 122 N UDDG 123 S UDDG=$O(^ORD(100.98,"B","UD RX",0)) 124 S $P(^OR(100,+ORID,0),U,11)=UDDG 125 Q 126 ISUDIV(ORY,ORIFN) ;True: OI of the order is for both UD and IV 127 N OI 128 S (OI,ORY)=0 129 S OI=+$O(^OR(100,+$G(ORIFN),.1,"B",0)) Q:OI<1 130 I $O(^ORD(101.43,OI,9,"B","IVM RX",0)) S ORY=1 131 Q 1 ORWDPS4 ;; SLC/JDL - Order Dialogs CO-PAY and Other;[12/31/01 6:38pm] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**116,125,131,141,173,187,190,195,215**;Dec 17, 1997 3 ; 4 CPLST(TEST,PTIFN,ORIFNS) ; --Get CP questions 5 N ORIFN,ORDA,ORI,ORPSO,CPX 6 S ORI=0,ORPSO=+$O(^DIC(9.4,"C","PSO",0)) 7 F S ORI=$O(ORIFNS(ORI)) Q:'ORI D 8 .S ORIFN=+ORIFNS(ORI),ORDA=$P(ORIFNS(ORI),";",2) 9 .I $D(^OR(100,ORIFN,0)),($P(^OR(100,ORIFN,0),U,14)=ORPSO) D 10 ..N PRIO S PRIO=0 11 ..I $D(^OR(100,ORIFN,4.5,"ID","URGENCY")) S PRIO=$O(^("URGENCY",0)) 12 ..S PRIO=$G(^OR(100,ORIFN,4.5,+PRIO,1)) 13 ..Q:PRIO=99 14 ..S CPX=$$SC(ORIFN) 15 ..I $L(CPX)>1 S TEST(ORIFN)=ORIFN_";"_ORDA_CPX 16 K PTIFN,ORIFN,ORDA,ORI,CPX 17 Q 18 ; 19 CPINFO(Y,ORINFO) ; -- Save reponses to CP questions 20 Q:'$D(ORINFO) 21 N ORIFN,ORI,ORX,ANS S ORI=0 22 F S ORI=$O(ORINFO(ORI)) Q:'ORI D 23 .S ORIFN=$P($P(ORINFO(ORI),U,1),";",1) 24 .S ANS=$P(ORINFO(ORI),U,2) 25 .D REFMT(.ORX,ANS) 26 .D SC^ORCSAVE2(.ORX,ORIFN) 27 S Y=1 28 K ORIFN,ORX,ORI,ANS 29 Q 30 ; 31 SC(ORIFN) ; -- Dialog validation, to ask CP questions 32 ;Expects ORIFN and ORDA 33 ; 34 N DR S DR="" 35 I '$L($T(SCNEW^PSOCP))!('$G(ORIFN))!('$G(ORDA)) Q DR 36 I $P($G(^OR(100,ORIFN,8,ORDA,0)),U,2)'="NW" Q DR 37 ; 38 N OR3,ORDRUG,ORENEW,ORX,I,XACT,YACT,CPNODE,ASC,AAO,AIR,AEC,AMST,AHNC,ACV 39 S ORX="",XACT="" 40 ;--Only new, renew, edited, copied outpatient order can continue... 41 ;AGP CHANGE 26.65, will returned service connection data for change orders 42 S OR3=$G(^OR(100,ORIFN,3)),XACT=$P(OR3,U,11) I (XACT'=0)&(XACT'=1)&((XACT'=2)&(XACT'="C")) Q DR 43 I (XACT=1)&($D(^OR(100,ORIFN,5))=0) Q DR 44 I $D(^OR(100,ORIFN,5))>0 D 45 .S CPNODE=$G(^OR(100,ORIFN,5)) 46 .S ASC=$S($L($P(CPNODE,"^",1)):"SC;"_$P(CPNODE,"^",1),1:"") 47 .S DR=$S($L(ASC):DR_U_ASC,1:DR) 48 .S AAO=$S($L($P(CPNODE,"^",3)):"AO;"_$P(CPNODE,"^",3),1:"") 49 .S DR=$S($L(AAO):DR_U_AAO,1:DR) 50 .S AIR=$S($L($P(CPNODE,"^",4)):"IR;"_$P(CPNODE,"^",4),1:"") 51 .S DR=$S($L(AIR):DR_U_AIR,1:DR) 52 .S AEC=$S($L($P(CPNODE,"^",5)):"EC;"_$P(CPNODE,"^",5),1:"") 53 .S DR=$S($L(AEC):DR_U_AEC,1:DR) 54 .S AMST=$S($L($P(CPNODE,"^",2)):"MST;"_$P(CPNODE,"^",2),1:"") 55 .S DR=$S($L(AMST):DR_U_AMST,1:DR) 56 .S AHNC=$S($L($P(CPNODE,"^",6)):"HNC;"_$P(CPNODE,"^",6),1:"") 57 .S DR=$S($L(AHNC):DR_U_AHNC,1:DR) 58 .S ACV=$S($L($P(CPNODE,"^",7)):"CV;"_$P(CPNODE,"^",7),1:"") 59 .S DR=$S($L(ACV):DR_U_ACV,1:DR) 60 .D CPCOMP(.DR) 61 .K ASC,AAO,AIR,AEC,AMST,AHNC,CPNODE 62 I $L(DR)>0 Q DR 63 I XACT=2 S YACT=$P(OR3,U,5),ORENEW=$G(^OR(100,YACT,4)) ;get PS# if renewal 64 S ORDRUG=$$VALUE^ORCSAVE2(ORIFN,"DRUG") 65 D SCNEW^PSOCP(.ORX,+PTIFN,ORDRUG,$G(ORENEW)) I '$D(ORX) Q DR 66 F I="SC","AO","IR","EC","MST","HNC","CV" D 67 . I $D(ORX(I)) S DR=DR_U_I_$S($L(ORX(I)):";"_ORX(I),1:"") 68 Q DR 69 REFMT(ORX,INFO) ; 70 ;"U": Unchecked ("NO") 71 ;"C": Checked ("YES") 72 ;"N" : Question not asked 73 N RST,RST1 74 S RST="" 75 F I=1:1:$L(INFO) S RST=RST_U_$S($E(INFO,I)="U":0,$E(INFO,I)="C":1,1:"") 76 S RST1=$E(RST,2,$L(RST)) 77 S ORX("SC")=$P(RST1,U,1) 78 S ORX("MST")=$P(RST1,U,5) 79 S ORX("AO")=$P(RST1,U,2) 80 S ORX("IR")=$P(RST1,U,3) 81 S ORX("EC")=$P(RST1,U,4) 82 S ORX("HNC")=$P(RST1,U,6) 83 S ORX("CV")=$P(RST1,U,7) 84 K RST,RST1 85 Q 86 CPCOMP(PREX) ; -- Compare the existed exemptions with new exemption questions 87 N ORX1,ORDRUG1,CPI,LSTCP,TMPVAL 88 S LSTCP="" 89 S ORDRUG1=$$VALUE^ORCSAVE2(ORIFN,"DRUG") 90 D SCNEW^PSOCP(.ORX1,+PTIFN,ORDRUG1,$G(ORENEW)) I '$D(ORX1) Q 91 F CPI="SC","AO","IR","EC","MST","HNC","CV" D 92 . I $D(ORX1(CPI)) D 93 . . S TMPVAL="" 94 . . I $F(PREX,CPI) D 95 . . . S TMPVAL=+$E(PREX,$F(PREX,CPI)+1) 96 . . . I $L(TMPVAL),((TMPVAL=0)!(TMPVAL=1)) S TMPVAL=CPI_";"_TMPVAL 97 . . . E S TMPVAL=CPI 98 . . E S TMPVAL=CPI 99 . . S LSTCP=LSTCP_U_TMPVAL 100 S PREX=LSTCP 101 Q 102 IPOD4OP(ORY,ORID) ;True: is an Inpt (IV OI) order on an OutPatient 103 Q:'$D(^OR(100,+ORID,0)) 104 S ORY=0 105 N APKG,ADLG,ADG,APTCLS,RXDG,UDDLG,IPPKG 106 S (RXDG,UDDLG,IPPKG)=0 107 S RXDG=+$O(^ORD(100.98,"B","O RX",0)) 108 S UDDLG=+$O(^ORD(101.41,"B","PSJ OR PAT OE",0)) 109 S IPPKG=+$O(^DIC(9.4,"B","INPATIENT MEDICATIONS",0)) 110 S ADLG=+$P($G(^OR(100,+ORID,0)),U,5) 111 S ADG=$P($G(^OR(100,+ORID,0)),U,11) 112 S APKG=$P($G(^OR(100,+ORID,0)),U,14) 113 S APTCLS=$P($G(^OR(100,+ORID,0)),U,12) 114 I ADG=RXDG,(ADLG=UDDLG),(APKG=IPPKG),(APTCLS="I") S ORY=1 115 Q 116 ; 117 UPDTDG(ORY,ORID) ;Update Inpt order for outpatient DG to Inpt DG 118 Q:'$D(^OR(100,+ORID,0)) 119 N UDDG 120 S UDDG=$O(^ORD(100.98,"B","UD RX",0)) 121 S $P(^OR(100,+ORID,0),U,11)=UDDG 122 Q 123 ISUDIV(ORY,ORIFN) ;True: OI of the order is for both UD and IV 124 N OI 125 S (OI,ORY)=0 126 S OI=+$O(^OR(100,+$G(ORIFN),.1,"B",0)) Q:OI<1 127 I $O(^ORD(101.43,OI,9,"B","IVM RX",0)) S ORY=1 128 Q
Note:
See TracChangeset
for help on using the changeset viewer.
