source: FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDPS4.m@ 1757

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 4.3 KB
Line 
1ORWDPS4 ;; 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 ;
4CPLST(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 ;
19CPINFO(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 ;
31SC(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
69REFMT(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
86CPCOMP(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
102IPOD4OP(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 ;
117UPDTDG(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
123ISUDIV(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 TracBrowser for help on using the repository browser.