source: WorldVistAEHR/trunk/r/CONTROLLED_SUBSTANCES-PSD/PSDDSOR.m@ 623

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

initial load of WorldVistAEHR

File size: 9.1 KB
Line 
1PSDDSOR ;BHM/MHA - Digitally signed CS Orders Report; 08/30/02
2 ;;3.0; CONTROLLED SUBSTANCES ;**40,42,45**;13 Feb 97
3 ;Ref. to ^PSRX( supp. by IA 1977
4 ;Ref. to ^PS(52.41, supp. by IA 3848
5 ;Ref. to ^PS(59, supp. by IA 2621
6 ;Ref. ^PSDRUG( supp. by IA 2621
7 ;Ref. to GETDATA^ORWOR1 supp. by IA 3750
8 ;
9 N AC,BDT,CT,DFN,DP,DRG,DRUG,DV,DVN,EDT,FI,NS,OP,ORD,ORS,PAT,PG,POS,PL,PL1,PRO,PROV
10 N PSDBD,PSDDF,PSDDV,PSDED,PSDIO,PSDPO,PSDPR,PSDPT,PSDRG,PSDSC,PSDSD
11 N PSDXF,RX,RX0,RX2,S1,S2,S3,S4,S5,S6,SCH,SR,SRT,TDT,TY,I,J,O,X,Y,Z
12 I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)
13SITE I '$D(PSOSITE) D Q:$D(DUOUT)!($D(DTOUT)) G:'$D(PSOSITE) SITE
14 .W ! S DIC("A")="Division: ",DIC=59,DIC(0)="AEMQ"
15 .S DIC("S")="I $S('$D(^PS(59,+Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0)"
16 .D ^DIC K DIC Q:$D(DUOUT)!($D(DTOUT)) I +Y>0 S PSOSITE=+Y Q
17 .W !!,"A 'DIVISION' must be selected! or Enter '^' to exit."
18 S PSDDV=PSOSITE
19 W !!?10,"You are logged on under the ",$P(^PS(59,PSDDV,0),"^")," division.",!
20DATE ;ask date range
21 W ! K %DT S %DT(0)=-DT,%DT="AEP",%DT("A")="Start Date: " D ^%DT
22 I Y<0!($D(DTOUT)) G END
23 S (%DT(0),PSDBD)=Y,%DT("A")="End Date: "
24 W ! D ^%DT I Y<0!($D(DTOUT)) G END
25 S PSDED=Y,PSDSD=PSDBD-.000001
26 W ! D KV S DIR("A")="Include discontinued orders",DIR(0)="Y",DIR("B")="NO"
27 D ^DIR K DIR G:$D(DIRUT) END S PSDDF=Y
28 W ! S DIR("A")="Include expired orders",DIR(0)="Y",DIR("B")="NO" D ^DIR
29 K DIR G:$D(DIRUT) END S PSDXF=Y
30 W ! S DIR("A")="Include pending orders",DIR(0)="Y",DIR("B")="NO" D ^DIR
31 K DIR G:$D(DIRUT) END S PSDPO=Y
32SL S (CT,PSDRG,PSDPR,PSDPT,PSDSC)=1,DP="Within ",DIR("B")="Drug" K SRT,SR
33 S OP="D:Drug;PR:Provider;PA:Patient;S:Schedule"
34 F D KV S DIR(0)="SAO^"_OP D Q:OP=""!($D(DUOUT))!($D(DTOUT))!($D(DIRUT))
35 .S:CT=1 DIR("B")="Drug" K:CT>1 DIR("B")
36 .S DIR("A")=$S(CT>1:DP,1:"")_"Sort By: " D ^DIR
37 .Q:$D(DIRUT)
38 .S O="" F I=1:1:$L(OP,";") S J=$P(OP,";",I) I J'[Y(0) S O=O_$S(O="":"",1:";")_J
39 .S OP=O
40 .S SRT(CT)=Y,SR(Y)=CT S CT=CT+1,DP=DP_$S(Y="D":"Drug, ",Y="PR":"Provider, ",Y="PA":"Patient, ",1:"Schedule, ")
41 .D @Y
42 G:$D(DUOUT)!($D(DTOUT)) END
43 I $D(SRT) K SR S I="" D G:$D(DIRUT) END G:'Y SL
44 .W !!,"You have selected the following:",!
45 .F S I=$O(SRT(I)) Q:I="" D
46 ..S J=SRT(I),SR(I)=$S(J="D":"DRUG",J="PR":"PROV",J="PA":"PAT",1:"SCH")
47 ..W !?5,$S(J="D":"Drug",J="PR":"Provider",J="PA":"Patient",1:"Schedule")
48 .W ! D KV S DIR("A")="Continue to print:",DIR("B")="Y",DIR(0)="YN" D ^DIR
49 G DEV Q
50D ;ask drug(s)
51 W !!,?5,"You may select a single drug, several drugs,",!,?5,"or enter ^ALL to select all drugs.",!!
52 K DRG,DIC S PSDRG=0,DIC("A")="Select DRUG: ",DIC=50,DIC(0)="QEAM"
53 S DIC("S")="I $S('$D(^(""I"")):1,'^(""I""):1,DT'>+^(""I""):1,1:0),$P($G(^(2)),""^"",3)[""O"",$D(^PSDRUG(""ASP"",+$G(^(2)),+Y)),+$P(^PSDRUG(+Y,0),""^"",3)&(+$P(^PSDRUG(+Y,0),""^"",3)<6)"
54 F D ^DIC Q:Y<0 S DRG(+Y)=""
55 K DIC I X="^ALL" S PSDRG=1 K DUOUT Q
56 Q:($D(DUOUT))!($D(DTOUT))
57 I '$D(DRG)&(Y<0) G D
58 Q
59PR ;ask provider(s)
60 W !!,?5,"You may select a single provider, several providers,",!,?5,"or enter ^ALL to select all providers.",!!
61 K PRO,DIC S PSDPR=0,DIC="^VA(200,",DIC(0)="QEAM",DIC("A")="Select Provider: "
62 F D ^DIC Q:Y<0 S PRO(+Y)=""
63 K DIC I X="^ALL" S PSDPR=1 K DUOUT Q
64 Q:$D(DUOUT)!($D(DTOUT))
65 I '$D(PRO)&(Y<0) G PR
66 Q
67PA ;ask provider(s)
68 W !!,?5,"You may select a single patient, several patients,",!,?5,"or enter ^ALL to select all patients.",!!
69 K PAT,DIC S PSDPT=0,DIC=2,DIC(0)="QEAM",DIC("A")="Select Patient: "
70 F D ^DIC Q:Y<0 S PAT(+Y)=""
71 K DIC I X="^ALL" S PSDPT=1 K DUOUT Q
72 Q:$D(DUOUT)!($D(DTOUT))
73 I '$D(PAT)&(Y<0) G PA
74 Q
75S ;
76 W !! K SCH,PSDSC D KV S DIR("A")="Include All CS Schedules: ",DIR("B")="Y",DIR(0)="YN" D ^DIR
77 Q:$D(DIRUT)
78 I Y S PSDSC=1 Q
79 F I=1:1:7 W !,?5,$S(I=1:"1 - SCHEDULE I",I=2:"2 - SCHEDULE II",I=3:"3 - SCHEDULE II NON-NARCOTICS",I=4:"4 - SCHEDULE III",I=5:"5 - SCHEDULE III NON-NARCOTICS",I=6:"6 - SCHEDULE IV NARCOTICS",1:"7 - SCHEDULE V NARCOTICS")
80 W ! D KV
81 S DIR(0)="L^1:7" D ^DIR Q:$D(DIRUT)
82 I Y,$L(Y,",")-1=1 S Y=+Y,SCH($S(Y<3:Y,Y=3:"2n",Y=4:3,Y=5:"3n",1:Y-2))="" Q
83 F I=1:1:$L(Y,",")-1 S J=+$P(Y,",",I) S SCH($S(J<3:J,J=3:"2n",J=4:3,J=5:"3n",1:J-2))=""
84 Q
85DEV K %ZIS,IOP,POP,ZTSK S PSDIO=ION,%ZIS="QM" D ^%ZIS K %ZIS
86 I POP S IOP=PSDIO D ^%ZIS K IOP,PSDIO W !,"Please try later!" G END
87 K PSDIO I $D(IO("Q")) K IO("Q"),ZTIO,ZTSAVE,ZTDTH,ZTSK D G END
88 .S ZTRTN="EN^PSDDSOR",ZTDESC="Digitally Signed CS Orders Report"
89 .F G="PSDDV","PSDSD","PSDBD","PSDED","PSDDF","PSDXF","PSDPO","PSDRG","PSDPR","PSDPT","PSDSC" S:$D(@G) ZTSAVE(G)=""
90 .S ZTSAVE("SRT(")="",ZTSAVE("SR(")="" S:$D(PRO) ZTSAVE("PRO(")="" S:$D(DRG) ZTSAVE("DRG(")="" S:$D(PAT) ZTSAVE("PAT(")="" S:$D(SCH) ZTSAVE("SCH(")=""
91 .D ^%ZTLOAD W:$D(ZTSK) !,"Report is Queued to print !!" K ZTSK
92EN ;
93 K ^TMP($J) S (I,NS)=0 F S I=$O(SR(I)) Q:'I S NS=I
94 S PND=0,TY="APKI",POS=PSDSD F S PSDSD=$O(^PSRX(TY,PSDSD)) Q:'PSDSD!(PSDSD>PSDED) D EN1
95 D:PSDPO EN2 D PSTR G END
96 Q
97EN1 S RX=0 F S RX=$O(^PSRX(TY,PSDSD,RX)) Q:'RX D
98 .Q:'$D(^PSRX(RX,0)) Q:$P(^(2),"^",9)'=PSDDV S RX0=^(0),ORD=$P($G(^("OR1")),"^",2)
99 .Q:'$P(RX0,"^",2)!('$P(RX0,"^",4))!('$P(RX0,"^",6))!('ORD)
100 .D GETD
101 Q
102EN2 S DV=0,FI=52.41,PND=1
103 F S POS=$O(^PS(FI,TY,POS)) Q:'POS!(POS>(PSDED_".999999")) S DV=0 F S DV=$O(^PS(FI,TY,POS,DV)) Q:'DV D
104 .S RX=0 F S RX=$O(^PS(FI,TY,POS,DV,RX)) Q:'RX D
105 ..Q:'$D(^PS(FI,RX,0)) S RX0=^(0)
106 ..I $P(RX0,"^",3)["NW"!($P(RX0,"^",3)="DC") I $P(RX0,"^",24) S ORD=$P(RX0,"^") D GETD
107 Q
108GETD ;
109 I $G(PSDPT) G GETD1
110 Q:'$D(PAT($P(RX0,"^",2)))
111GETD1 ;
112 D GETDATA^ORWOR1(.Y,ORD,$P(RX0,"^",2)) Q:Y<0 D:$G(PND)
113 .S Y=Y_"^"_$P(RX0,"^",3)
114 .I $P(RX0,"^",3)="DC",$G(^PS(52.41,RX,4))]"" D
115 ..S Y=Y_"^"_$TR(^PS(52.41,RX,4),":",","),$P(Y,"^",4)="5;DISCONTINUED"
116 D CONT
117 Q
118CONT ;
119 S ORS=+$P(Y,"^",4) Q:'ORS!('PSDXF&(ORS=7))
120 Q:'PSDDF&(",1,12,13,"[(","_ORS_","))
121 S S1=$S(ORS=5:4,ORS=7:3,",1,12,13,"[(","_ORS_","):2,1:1)
122 S PAT=$P($G(Y(1)),"^") Q:PAT=""
123 S DRUG=$S($P($G(Y(2)),"^")]"":$P(Y(2),"^"),$P($G(Y(6)),"^")]"":$P(Y(6),"^"),1:"")
124 G:$G(PSDRG) CT1
125 Q:'$D(DRG($P(Y(2),"^",2)))
126CT1 S PROV=$P($G(Y(4)),"^") Q:PROV=""
127 G:$G(PSDPR) CT2
128 Q:'$D(PRO($P(Y(4),"^",2)))
129CT2 S SCH=$P($G(Y(2)),"^",5) Q:SCH=""
130 G:$G(PSDSC) CT3
131 Q:'$D(SCH($P(Y(2),"^",5)))
132CT3 I NS=4 D Q
133 .S ^TMP($J,S1,@(SR(1)),@(SR(2)),@(SR(3)),@(SR(4)),RX,0)=Y,I=0
134 .F S I=$O(Y(I)) Q:'I S ^TMP($J,S1,@(SR(1)),@(SR(2)),@(SR(3)),@(SR(4)),RX,I)=Y(I)
135 I NS=3 D Q
136 .S ^TMP($J,S1,@(SR(1)),@(SR(2)),@(SR(3)),RX,0)=Y,I=0
137 .F S I=$O(Y(I)) Q:'I S ^TMP($J,S1,@(SR(1)),@(SR(2)),@(SR(3)),RX,I)=Y(I)
138 I NS=2 D Q
139 .S ^TMP($J,S1,@(SR(1)),@(SR(2)),RX,0)=Y,I=0
140 .F S I=$O(Y(I)) Q:'I S ^TMP($J,S1,@(SR(1)),@(SR(2)),RX,I)=Y(I)
141 S ^TMP($J,S1,@(SR(1)),RX,0)=Y,I=0
142 F S I=$O(Y(I)) Q:'I S ^TMP($J,S1,@(SR(1)),RX,I)=Y(I)
143 Q
144 ;
145PSTR D NOW^%DTC S TDT=$E(%,4,5)_"/"_$E(%,6,7)_"/"_$E(%,2,3)_"@"_$E(%,9,10)_":"_$E(%,11,12)
146 N P1,P2 S $E(P1,42)="",$E(P2,12)="",PG=1,Y=PSDBD D D^DIQ S BDT=Y,Y=PSDED D D^DIQ S EDT=Y
147 S DVN=$$GET1^DIQ(59,PSDDV,.01) S:DVN]"" DVN=$E(DVN,1,20) S:DVN="" DVN="N/A"
148 U IO I '$D(^TMP($J)) D HD W !!,"********** NO DATA TO PRINT **********",!! Q
149 D @("N"_NS)
150 Q
151IN K Y0,Y1,Y2,Y3,Y4,Y5,Y6 S S6=""
152 Q
153WR S PG=1 D HD W !,$S(AC=1:"Processed",AC=2:"Discontinued",AC=3:"Expired",1:"Pending")_" Orders:",! Q
154N4 S AC="" F S AC=$O(^TMP($J,AC)) Q:'AC D WR D Q:$D(DIRUT) D HD1 Q:$D(DIRUT)
155 .S S1="" F S S1=$O(^TMP($J,AC,S1)) Q:S1="" S S2="" F S S2=$O(^TMP($J,AC,S1,S2)) Q:S2="" D Q:$D(DIRUT)
156 ..S S3="" F S S3=$O(^TMP($J,AC,S1,S2,S3)) Q:S3="" S S4="" F S S4=$O(^TMP($J,AC,S1,S2,S3,S4)) Q:S4="" D Q:$D(DIRUT)
157 ...S S5="" F S S5=$O(^TMP($J,AC,S1,S2,S3,S4,S5)) Q:S5="" D STR4 Q:$D(DIRUT)
158 Q
159STR4 ;
160 D IN F S S6=$O(^TMP($J,AC,S1,S2,S3,S4,S5,S6)) Q:S6="" S Z="Y"_S6,@Z=^TMP($J,AC,S1,S2,S3,S4,S5,S6)
161 D PRT Q
162N3 S AC="" F S AC=$O(^TMP($J,AC)) Q:'AC D WR D Q:$D(DIRUT) D HD1 Q:$D(DIRUT)
163 .S S1="" F S S1=$O(^TMP($J,AC,S1)) Q:S1="" S S2="" F S S2=$O(^TMP($J,AC,S1,S2)) Q:S2="" D Q:$D(DIRUT)
164 ..S S3="" F S S3=$O(^TMP($J,AC,S1,S2,S3)) Q:S3="" D Q:$D(DIRUT)
165 ...S S5="" F S S5=$O(^TMP($J,AC,S1,S2,S3,S5)) Q:S5="" D STR3 Q:$D(DIRUT)
166 Q
167STR3 D IN F S S6=$O(^TMP($J,AC,S1,S2,S3,S5,S6)) Q:S6="" S Z="Y"_S6,@Z=^TMP($J,AC,S1,S2,S3,S5,S6)
168 D PRT Q
169N2 S AC="" F S AC=$O(^TMP($J,AC)) Q:'AC D WR D Q:$D(DIRUT) D HD1 Q:$D(DIRUT)
170 .S S1="" F S S1=$O(^TMP($J,AC,S1)) Q:S1="" S S2="" F S S2=$O(^TMP($J,AC,S1,S2)) Q:S2="" D Q:$D(DIRUT)
171 ..S S5="" F S S5=$O(^TMP($J,AC,S1,S2,S5)) Q:S5="" D STR2 Q:$D(DIRUT)
172 Q
173STR2 D IN F S S6=$O(^TMP($J,AC,S1,S2,S5,S6)) Q:S6="" S Z="Y"_S6,@Z=^TMP($J,AC,S1,S2,S5,S6)
174 D PRT Q
175N1 S AC="" F S AC=$O(^TMP($J,AC)) Q:'AC D WR D Q:$D(DIRUT) D HD1 Q:$D(DIRUT)
176 .S S1="" F S S1=$O(^TMP($J,AC,S1)) Q:S1="" D Q:$D(DIRUT)
177 ..S S5="" F S S5=$O(^TMP($J,AC,S1,S5)) Q:S5="" D STR1 Q:$D(DIRUT)
178 Q
179STR1 D IN F S S6=$O(^TMP($J,AC,S1,S5,S6)) Q:S6="" S Z="Y"_S6,@Z=^TMP($J,AC,S1,S5,S6)
180 D PRT
181 Q
182PRT D:($Y+4)>IOSL HD Q:$D(DIRUT) D PRT^PSDDSOR1
183 Q
184HD D HD1 Q:$D(DIRUT)
185 W @IOF,!?2,"Digitally Signed CS Orders Report for Division "_DVN,?70,"Page: ",PG
186 W !,?8,"Date Range: "_BDT_" - "_EDT,?53,"Printed on: "_TDT,!
187 S PG=PG+1
188 Q
189HD1 I PG>1,$E(IOST)="C" K DIR S DIR(0)="E",DIR("A")=" Press Return to Continue or ^ to Exit" D ^DIR K DIR
190 Q
191END W ! D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
192 K ^TMP($J),PSDDV,PSDSD,PSDED,PSDDF,PSDXF,DRG,PRO,PAT,PND,SCH,SRT,PSDRG,PSDPR,PSDPT,PSDSC,VA,Y0,Y1,Y2,Y3,Y4,Y5,Y6
193KV K DIR,DIRUT,DTOUT,DUOUT
194 Q
Note: See TracBrowser for help on using the repository browser.