PSDDSOR ;BHM/MHA/PWC - Digitally signed CS Orders Report; 08/30/02
;;3.0; CONTROLLED SUBSTANCES ;**40,42,45,67**;13 Feb 97;Build 8
;Ref. to ^PSRX( supp. by IA 1977
;Ref. to ^PS(52.41, supp. by IA 3848
;Ref. to ^PS(59, supp. by IA 2621
;Ref. ^PSDRUG( supp. by IA 2621
;Ref. to GETDATA^ORWOR1 supp. by IA 3750
;
N AC,BDT,CT,DFN,DP,DRG,DRUG,DV,DVN,EDT,FI,NS,OP,ORD,ORS,PAT,PG,POS,PL,PL1,PRO,PROV
N PSDBD,PSDDF,PSDDV,PSDED,PSDIO,PSDPO,PSDPR,PSDPT,PSDRG,PSDSC,PSDSD
N PSDXF,RX,RX0,RX2,S1,S2,S3,S4,S5,S6,SCH,SR,SRT,TDT,TY,I,J,O,X,Y,Z
I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)
SITE I '$D(PSOSITE) D Q:$D(DUOUT)!($D(DTOUT)) G:'$D(PSOSITE) SITE
.W ! S DIC("A")="Division: ",DIC=59,DIC(0)="AEMQ"
.S DIC("S")="I $S('$D(^PS(59,+Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0)"
.D ^DIC K DIC Q:$D(DUOUT)!($D(DTOUT)) I +Y>0 S PSOSITE=+Y Q
.W !!,"A 'DIVISION' must be selected! or Enter '^' to exit."
S PSDDV=PSOSITE
W !!?10,"You are logged on under the ",$P(^PS(59,PSDDV,0),"^")," division.",!
DATE ;ask date range
W ! K %DT S %DT(0)=-DT,%DT="AEP",%DT("A")="Start Date: " D ^%DT
I Y<0!($D(DTOUT)) G END
S (%DT(0),PSDBD)=Y,%DT("A")="End Date: "
W ! D ^%DT I Y<0!($D(DTOUT)) G END
S PSDED=Y,PSDSD=PSDBD-.000001
W ! D KV S DIR("A")="Include discontinued orders",DIR(0)="Y",DIR("B")="NO"
D ^DIR K DIR G:$D(DIRUT) END S PSDDF=Y
W ! S DIR("A")="Include expired orders",DIR(0)="Y",DIR("B")="NO" D ^DIR
K DIR G:$D(DIRUT) END S PSDXF=Y
W ! S DIR("A")="Include pending orders",DIR(0)="Y",DIR("B")="NO" D ^DIR
K DIR G:$D(DIRUT) END S PSDPO=Y
SL S (CT,PSDRG,PSDPR,PSDPT,PSDSC)=1,DP="Within ",DIR("B")="Drug" K SRT,SR
S OP="D:Drug;PR:Provider;PA:Patient;S:Schedule"
F D KV S DIR(0)="SAO^"_OP D Q:OP=""!($D(DUOUT))!($D(DTOUT))!($D(DIRUT))
.S:CT=1 DIR("B")="Drug" K:CT>1 DIR("B")
.S DIR("A")=$S(CT>1:DP,1:"")_"Sort By: " D ^DIR
.Q:$D(DIRUT)
.S O="" F I=1:1:$L(OP,";") S J=$P(OP,";",I) I J'[Y(0) S O=O_$S(O="":"",1:";")_J
.S OP=O
.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, ")
.D @Y
G:$D(DUOUT)!($D(DTOUT)) END
I $D(SRT) K SR S I="" D G:$D(DIRUT) END G:'Y SL
.W !!,"You have selected the following:",!
.F S I=$O(SRT(I)) Q:I="" D
..S J=SRT(I),SR(I)=$S(J="D":"DRUG",J="PR":"PROV",J="PA":"PAT",1:"SCH")
..W !?5,$S(J="D":"Drug",J="PR":"Provider",J="PA":"Patient",1:"Schedule")
.W ! D KV S DIR("A")="Continue to print:",DIR("B")="Y",DIR(0)="YN" D ^DIR
G DEV Q
D ;ask drug(s)
W !!,?5,"You may select a single drug, several drugs,",!,?5,"or enter ^ALL to select all drugs.",!!
K DRG,DIC S PSDRG=0,DIC("A")="Select DRUG: ",DIC=50,DIC(0)="QEAM"
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)"
F D ^DIC Q:Y<0 S DRG(+Y)=""
S X=$$UP^XLFSTR(X) ; PSD*3*67 pwc
K DIC I X="^ALL" S PSDRG=1 K DUOUT Q
Q:($D(DUOUT))!($D(DTOUT))
I '$D(DRG)&(Y<0) G D
Q
PR ;ask provider(s)
W !!,?5,"You may select a single provider, several providers,",!,?5,"or enter ^ALL to select all providers.",!!
K PRO,DIC S PSDPR=0,DIC="^VA(200,",DIC(0)="QEAM",DIC("A")="Select Provider: "
F D ^DIC Q:Y<0 S PRO(+Y)=""
S X=$$UP^XLFSTR(X) ; PSD*3*67 PWC
K DIC I X="^ALL" S PSDPR=1 K DUOUT Q
Q:$D(DUOUT)!($D(DTOUT))
I '$D(PRO)&(Y<0) G PR
Q
PA ;ask patient(s)
W !!,?5,"You may select a single patient, several patients,",!,?5,"or enter ^ALL to select all patients.",!!
K PAT,DIC S PSDPT=0,DIC=2,DIC(0)="QEAM",DIC("A")="Select Patient: "
F D ^DIC Q:Y<0 S PAT(+Y)=""
S X=$$UP^XLFSTR(X) ; PSD*3*67 pwc
K DIC I X="^ALL" S PSDPT=1 K DUOUT Q
Q:$D(DUOUT)!($D(DTOUT))
I '$D(PAT)&(Y<0) G PA
Q
S ;
W !! K SCH,PSDSC D KV S DIR("A")="Include All CS Schedules: ",DIR("B")="Y",DIR(0)="YN" D ^DIR
Q:$D(DIRUT)
I Y S PSDSC=1 Q
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")
W ! D KV
S DIR(0)="L^1:7" D ^DIR Q:$D(DIRUT)
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
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))=""
Q
DEV K %ZIS,IOP,POP,ZTSK S PSDIO=ION,%ZIS="QM" D ^%ZIS K %ZIS
I POP S IOP=PSDIO D ^%ZIS K IOP,PSDIO W !,"Please try later!" G END
K PSDIO I $D(IO("Q")) K IO("Q"),ZTIO,ZTSAVE,ZTDTH,ZTSK D G END
.S ZTRTN="EN^PSDDSOR",ZTDESC="Digitally Signed CS Orders Report"
.F G="PSDDV","PSDSD","PSDBD","PSDED","PSDDF","PSDXF","PSDPO","PSDRG","PSDPR","PSDPT","PSDSC" S:$D(@G) ZTSAVE(G)=""
.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(")=""
.D ^%ZTLOAD W:$D(ZTSK) !,"Report is Queued to print !!" K ZTSK
EN ;
K ^TMP($J) S (I,NS)=0 F S I=$O(SR(I)) Q:'I S NS=I
S PND=0,TY="APKI",POS=PSDSD F S PSDSD=$O(^PSRX(TY,PSDSD)) Q:'PSDSD!(PSDSD>PSDED) D EN1
D:PSDPO EN2 D PSTR G END
Q
EN1 S RX=0 F S RX=$O(^PSRX(TY,PSDSD,RX)) Q:'RX D
.Q:'$D(^PSRX(RX,0)) Q:$P(^(2),"^",9)'=PSDDV S RX0=^(0),ORD=$P($G(^("OR1")),"^",2)
.Q:'$P(RX0,"^",2)!('$P(RX0,"^",4))!('$P(RX0,"^",6))!('ORD)
.D GETD
Q
EN2 S DV=0,FI=52.41,PND=1
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
.S RX=0 F S RX=$O(^PS(FI,TY,POS,DV,RX)) Q:'RX D
..Q:'$D(^PS(FI,RX,0)) S RX0=^(0)
..I $P(RX0,"^",3)["NW"!($P(RX0,"^",3)="DC") I $P(RX0,"^",24) S ORD=$P(RX0,"^") D GETD
Q
GETD ;
I $G(PSDPT) G GETD1
Q:'$D(PAT($P(RX0,"^",2)))
GETD1 ;
D GETDATA^ORWOR1(.Y,ORD,$P(RX0,"^",2)) Q:Y<0 D:$G(PND)
.S Y=Y_"^"_$P(RX0,"^",3)
.I $P(RX0,"^",3)="DC",$G(^PS(52.41,RX,4))]"" D
..S Y=Y_"^"_$TR(^PS(52.41,RX,4),":",","),$P(Y,"^",4)="5;DISCONTINUED"
D CONT
Q
CONT ;
S ORS=+$P(Y,"^",4) Q:'ORS!('PSDXF&(ORS=7))
Q:'PSDDF&(",1,12,13,"[(","_ORS_","))
S S1=$S(ORS=5:4,ORS=7:3,",1,12,13,"[(","_ORS_","):2,1:1)
S PAT=$P($G(Y(1)),"^") Q:PAT=""
S DRUG=$S($P($G(Y(2)),"^")]"":$P(Y(2),"^"),$P($G(Y(6)),"^")]"":$P(Y(6),"^"),1:"")
G:$G(PSDRG) CT1
Q:'$D(DRG($P(Y(2),"^",2)))
CT1 S PROV=$P($G(Y(4)),"^") Q:PROV=""
G:$G(PSDPR) CT2
Q:'$D(PRO($P(Y(4),"^",2)))
CT2 S SCH=$P($G(Y(2)),"^",5) Q:SCH=""
G:$G(PSDSC) CT3
Q:'$D(SCH($P(Y(2),"^",5)))
CT3 I NS=4 D Q
.S ^TMP($J,S1,@(SR(1)),@(SR(2)),@(SR(3)),@(SR(4)),RX,0)=Y,I=0
.F S I=$O(Y(I)) Q:'I S ^TMP($J,S1,@(SR(1)),@(SR(2)),@(SR(3)),@(SR(4)),RX,I)=Y(I)
I NS=3 D Q
.S ^TMP($J,S1,@(SR(1)),@(SR(2)),@(SR(3)),RX,0)=Y,I=0
.F S I=$O(Y(I)) Q:'I S ^TMP($J,S1,@(SR(1)),@(SR(2)),@(SR(3)),RX,I)=Y(I)
I NS=2 D Q
.S ^TMP($J,S1,@(SR(1)),@(SR(2)),RX,0)=Y,I=0
.F S I=$O(Y(I)) Q:'I S ^TMP($J,S1,@(SR(1)),@(SR(2)),RX,I)=Y(I)
S ^TMP($J,S1,@(SR(1)),RX,0)=Y,I=0
F S I=$O(Y(I)) Q:'I S ^TMP($J,S1,@(SR(1)),RX,I)=Y(I)
Q
;
PSTR D NOW^%DTC S TDT=$E(%,4,5)_"/"_$E(%,6,7)_"/"_$E(%,2,3)_"@"_$E(%,9,10)_":"_$E(%,11,12)
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
S DVN=$$GET1^DIQ(59,PSDDV,.01) S:DVN]"" DVN=$E(DVN,1,20) S:DVN="" DVN="N/A"
U IO I '$D(^TMP($J)) D HD W !!,"********** NO DATA TO PRINT **********",!! Q
D @("N"_NS)
Q
IN K Y0,Y1,Y2,Y3,Y4,Y5,Y6 S S6=""
Q
WR S PG=1 D HD W !,$S(AC=1:"Processed",AC=2:"Discontinued",AC=3:"Expired",1:"Pending")_" Orders:",! Q
N4 S AC="" F S AC=$O(^TMP($J,AC)) Q:'AC D WR D Q:$D(DIRUT) D HD1 Q:$D(DIRUT)
.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)
..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)
...S S5="" F S S5=$O(^TMP($J,AC,S1,S2,S3,S4,S5)) Q:S5="" D STR4 Q:$D(DIRUT)
Q
STR4 ;
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)
D PRT Q
N3 S AC="" F S AC=$O(^TMP($J,AC)) Q:'AC D WR D Q:$D(DIRUT) D HD1 Q:$D(DIRUT)
.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)
..S S3="" F S S3=$O(^TMP($J,AC,S1,S2,S3)) Q:S3="" D Q:$D(DIRUT)
...S S5="" F S S5=$O(^TMP($J,AC,S1,S2,S3,S5)) Q:S5="" D STR3 Q:$D(DIRUT)
Q
STR3 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)
D PRT Q
N2 S AC="" F S AC=$O(^TMP($J,AC)) Q:'AC D WR D Q:$D(DIRUT) D HD1 Q:$D(DIRUT)
.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)
..S S5="" F S S5=$O(^TMP($J,AC,S1,S2,S5)) Q:S5="" D STR2 Q:$D(DIRUT)
Q
STR2 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)
D PRT Q
N1 S AC="" F S AC=$O(^TMP($J,AC)) Q:'AC D WR D Q:$D(DIRUT) D HD1 Q:$D(DIRUT)
.S S1="" F S S1=$O(^TMP($J,AC,S1)) Q:S1="" D Q:$D(DIRUT)
..S S5="" F S S5=$O(^TMP($J,AC,S1,S5)) Q:S5="" D STR1 Q:$D(DIRUT)
Q
STR1 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)
D PRT
Q
PRT D:($Y+4)>IOSL HD Q:$D(DIRUT) D PRT^PSDDSOR1
Q
HD D HD1 Q:$D(DIRUT)
W @IOF,!?2,"Digitally Signed CS Orders Report for Division "_DVN,?70,"Page: ",PG
W !,?8,"Date Range: "_BDT_" - "_EDT,?53,"Printed on: "_TDT,!
S PG=PG+1
Q
HD1 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
Q
END W ! D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
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
KV K DIR,DIRUT,DTOUT,DUOUT
Q
PSDDSOR ;BHM/MHA/PWC - Digitally signed CS Orders Report; 08/30/02
+1 ;;3.0; CONTROLLED SUBSTANCES ;**40,42,45,67**;13 Feb 97;Build 8
+2 ;Ref. to ^PSRX( supp. by IA 1977
+3 ;Ref. to ^PS(52.41, supp. by IA 3848
+4 ;Ref. to ^PS(59, supp. by IA 2621
+5 ;Ref. ^PSDRUG( supp. by IA 2621
+6 ;Ref. to GETDATA^ORWOR1 supp. by IA 3750
+7 ;
+8 NEW AC,BDT,CT,DFN,DP,DRG,DRUG,DV,DVN,EDT,FI,NS,OP,ORD,ORS,PAT,PG,POS,PL,PL1,PRO,PROV
+9 NEW PSDBD,PSDDF,PSDDV,PSDED,PSDIO,PSDPO,PSDPR,PSDPT,PSDRG,PSDSC,PSDSD
+10 NEW PSDXF,RX,RX0,RX2,S1,S2,S3,S4,S5,S6,SCH,SR,SRT,TDT,TY,I,J,O,X,Y,Z
+11 IF '$DATA(PSDSITE)
DO ^PSDSET
IF '$DATA(PSDSITE)
QUIT
SITE IF '$DATA(PSOSITE)
Begin DoDot:1
+1 WRITE !
SET DIC("A")="Division: "
SET DIC=59
SET DIC(0)="AEMQ"
+2 SET DIC("S")="I $S('$D(^PS(59,+Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0)"
+3 DO ^DIC
KILL DIC
IF $DATA(DUOUT)!($DATA(DTOUT))
QUIT
IF +Y>0
SET PSOSITE=+Y
QUIT
+4 WRITE !!,"A 'DIVISION' must be selected! or Enter '^' to exit."
End DoDot:1
IF $DATA(DUOUT)!($DATA(DTOUT))
QUIT
IF '$DATA(PSOSITE)
GOTO SITE
+5 SET PSDDV=PSOSITE
+6 WRITE !!?10,"You are logged on under the ",$PIECE(^PS(59,PSDDV,0),"^")," division.",!
DATE ;ask date range
+1 WRITE !
KILL %DT
SET %DT(0)=-DT
SET %DT="AEP"
SET %DT("A")="Start Date: "
DO ^%DT
+2 IF Y<0!($DATA(DTOUT))
GOTO END
+3 SET (%DT(0),PSDBD)=Y
SET %DT("A")="End Date: "
+4 WRITE !
DO ^%DT
IF Y<0!($DATA(DTOUT))
GOTO END
+5 SET PSDED=Y
SET PSDSD=PSDBD-.000001
+6 WRITE !
DO KV
SET DIR("A")="Include discontinued orders"
SET DIR(0)="Y"
SET DIR("B")="NO"
+7 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
GOTO END
SET PSDDF=Y
+8 WRITE !
SET DIR("A")="Include expired orders"
SET DIR(0)="Y"
SET DIR("B")="NO"
DO ^DIR
+9 KILL DIR
IF $DATA(DIRUT)
GOTO END
SET PSDXF=Y
+10 WRITE !
SET DIR("A")="Include pending orders"
SET DIR(0)="Y"
SET DIR("B")="NO"
DO ^DIR
+11 KILL DIR
IF $DATA(DIRUT)
GOTO END
SET PSDPO=Y
SL SET (CT,PSDRG,PSDPR,PSDPT,PSDSC)=1
SET DP="Within "
SET DIR("B")="Drug"
KILL SRT,SR
+1 SET OP="D:Drug;PR:Provider;PA:Patient;S:Schedule"
+2 FOR
DO KV
SET DIR(0)="SAO^"_OP
Begin DoDot:1
+3 IF CT=1
SET DIR("B")="Drug"
IF CT>1
KILL DIR("B")
+4 SET DIR("A")=$SELECT(CT>1:DP,1:"")_"Sort By: "
DO ^DIR
+5 IF $DATA(DIRUT)
QUIT
+6 SET O=""
FOR I=1:1:$LENGTH(OP,";")
SET J=$PIECE(OP,";",I)
IF J'[Y(0)
SET O=O_$SELECT(O="":"",1:";")_J
+7 SET OP=O
+8 SET SRT(CT)=Y
SET SR(Y)=CT
SET CT=CT+1
SET DP=DP_$SELECT(Y="D":"Drug, ",Y="PR":"Provider, ",Y="PA":"Patient, ",1:"Schedule, ")
+9 DO @Y
End DoDot:1
IF OP=""!($DATA(DUOUT))!($DATA(DTOUT))!($DATA(DIRUT))
QUIT
+10 IF $DATA(DUOUT)!($DATA(DTOUT))
GOTO END
+11 IF $DATA(SRT)
KILL SR
SET I=""
Begin DoDot:1
+12 WRITE !!,"You have selected the following:",!
+13 FOR
SET I=$ORDER(SRT(I))
IF I=""
QUIT
Begin DoDot:2
+14 SET J=SRT(I)
SET SR(I)=$SELECT(J="D":"DRUG",J="PR":"PROV",J="PA":"PAT",1:"SCH")
+15 WRITE !?5,$SELECT(J="D":"Drug",J="PR":"Provider",J="PA":"Patient",1:"Schedule")
End DoDot:2
+16 WRITE !
DO KV
SET DIR("A")="Continue to print:"
SET DIR("B")="Y"
SET DIR(0)="YN"
DO ^DIR
End DoDot:1
IF $DATA(DIRUT)
GOTO END
IF 'Y
GOTO SL
+17 GOTO DEV
QUIT
D ;ask drug(s)
+1 WRITE !!,?5,"You may select a single drug, several drugs,",!,?5,"or enter ^ALL to select all drugs.",!!
+2 KILL DRG,DIC
SET PSDRG=0
SET DIC("A")="Select DRUG: "
SET DIC=50
SET DIC(0)="QEAM"
+3 SET DDSOR_source.html#xD">DIC("S")="I $S('$DDSOR_source.html#xD">D(^(""I"")):1,'^(""I""):1,DDSOR_source.html#xD">DT'>+^(""I""):1,1:0),$P($G(^(2)),""^"",3)[""O"",$DDSOR_source.html#xD">D(^PSDDSOR_source.html#xD">DRUG(""ASP"",+$G(^(2)),+Y)),+$P(^PSDDSOR_source.html#xD">DRUG(+Y,0),""^"",3)&(+$P(^PSDDSOR_source.html#xD">DRUG(+Y,0),""^"",3)<6)"
+4 FOR
DO ^DIC
IF Y<0
QUIT
SET DRG(+Y)=""
+5 ; PSD*3*67 pwc
SET X=$$UP^XLFSTR(X)
+6 KILL DIC
IF X="^ALL"
SET PSDRG=1
KILL DUOUT
QUIT
+7 IF ($DATA(DUOUT))!($DATA(DTOUT))
QUIT
+8 IF '$DATA(DRG)&(Y<0)
GOTO D
+9 QUIT
PR ;ask provider(s)
+1 WRITE !!,?5,"You may select a single provider, several providers,",!,?5,"or enter ^ALL to select all providers.",!!
+2 KILL PRO,DIC
SET PSDPR=0
SET DIC="^VA(200,"
SET DIC(0)="QEAM"
SET DIC("A")="Select Provider: "
+3 FOR
DO ^DIC
IF Y<0
QUIT
SET PRO(+Y)=""
+4 ; PSD*3*67 PWC
SET X=$$UP^XLFSTR(X)
+5 KILL DIC
IF X="^ALL"
SET PSDPR=1
KILL DUOUT
QUIT
+6 IF $DATA(DUOUT)!($DATA(DTOUT))
QUIT
+7 IF '$DATA(PRO)&(Y<0)
GOTO PR
+8 QUIT
PA ;ask patient(s)
+1 WRITE !!,?5,"You may select a single patient, several patients,",!,?5,"or enter ^ALL to select all patients.",!!
+2 KILL PAT,DIC
SET PSDPT=0
SET DIC=2
SET DIC(0)="QEAM"
SET DIC("A")="Select Patient: "
+3 FOR
DO ^DIC
IF Y<0
QUIT
SET PAT(+Y)=""
+4 ; PSD*3*67 pwc
SET X=$$UP^XLFSTR(X)
+5 KILL DIC
IF X="^ALL"
SET PSDPT=1
KILL DUOUT
QUIT
+6 IF $DATA(DUOUT)!($DATA(DTOUT))
QUIT
+7 IF '$DATA(PAT)&(Y<0)
GOTO PA
+8 QUIT
S ;
+1 WRITE !!
KILL SCH,PSDSC
DO KV
SET DIR("A")="Include All CS Schedules: "
SET DIR("B")="Y"
SET DIR(0)="YN"
DO ^DIR
+2 IF $DATA(DIRUT)
QUIT
+3 IF Y
SET PSDSC=1
QUIT
+4 FOR I=1:1:7
WRITE !,?5,$SELECT(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")
+5 WRITE !
DO KV
+6 SET DIR(0)="L^1:7"
DO ^DIR
IF $DATA(DIRUT)
QUIT
+7 IF Y
IF $LENGTH(Y,",")-1=1
SET Y=+Y
SET SCH($SELECT(Y<3:Y,Y=3:"2n",Y=4:3,Y=5:"3n",1:Y-2))=""
QUIT
+8 FOR I=1:1:$LENGTH(Y,",")-1
SET J=+$PIECE(Y,",",I)
SET SCH($SELECT(J<3:J,J=3:"2n",J=4:3,J=5:"3n",1:J-2))=""
+9 QUIT
DEV KILL %ZIS,IOP,POP,ZTSK
SET PSDIO=ION
SET %ZIS="QM"
DO ^%ZIS
KILL %ZIS
+1 IF POP
SET IOP=PSDIO
DO ^%ZIS
KILL IOP,PSDIO
WRITE !,"Please try later!"
GOTO END
+2 KILL PSDIO
IF $DATA(IO("Q"))
KILL IO("Q"),ZTIO,ZTSAVE,ZTDTH,ZTSK
Begin DoDot:1
+3 SET ZTRTN="EN^PSDDSOR"
SET ZTDESC="Digitally Signed CS Orders Report"
+4 FOR G="PSDDV","PSDSD","PSDBD","PSDED","PSDDF","PSDXF","PSDPO","PSDRG","PSDPR","PSDPT","PSDSC"
IF $DATA(@G)
SET ZTSAVE(G)=""
+5 SET ZTSAVE("SRT(")=""
SET ZTSAVE("SR(")=""
IF $DATA(PRO)
SET ZTSAVE("PRO(")=""
IF $DATA(DRG)
SET ZTSAVE("DRG(")=""
IF $DATA(PAT)
SET ZTSAVE("PAT(")=""
IF $DATA(SCH)
SET ZTSAVE("SCH(")=""
+6 DO ^%ZTLOAD
IF $DATA(ZTSK)
WRITE !,"Report is Queued to print !!"
KILL ZTSK
End DoDot:1
GOTO END
EN ;
+1 KILL ^TMP($JOB)
SET (I,NS)=0
FOR
SET I=$ORDER(SR(I))
IF 'I
QUIT
SET NS=I
+2 SET PND=0
SET TY="APKI"
SET POS=PSDSD
FOR
SET PSDSD=$ORDER(^PSRX(TY,PSDSD))
IF 'PSDSD!(PSDSD>PSDED)
QUIT
DO EN1
+3 IF PSDPO
DO EN2
DO PSTR
GOTO END
+4 QUIT
EN1 SET RX=0
FOR
SET RX=$ORDER(^PSRX(TY,PSDSD,RX))
IF 'RX
QUIT
Begin DoDot:1
+1 IF '$DATA(^PSRX(RX,0))
QUIT
IF $PIECE(^(2),"^",9)'=PSDDV
QUIT
SET RX0=^(0)
SET ORD=$PIECE($GET(^("OR1")),"^",2)
+2 IF '$PIECE(RX0,"^",2)!('$PIECE(RX0,"^",4))!('$PIECE(RX0,"^",6))!('ORD)
QUIT
+3 DO GETD
End DoDot:1
+4 QUIT
EN2 SET DV=0
SET FI=52.41
SET PND=1
+1 FOR
SET POS=$ORDER(^PS(FI,TY,POS))
IF 'POS!(POS>(PSDED_".999999"))
QUIT
SET DV=0
FOR
SET DV=$ORDER(^PS(FI,TY,POS,DV))
IF 'DV
QUIT
Begin DoDot:1
+2 SET RX=0
FOR
SET RX=$ORDER(^PS(FI,TY,POS,DV,RX))
IF 'RX
QUIT
Begin DoDot:2
+3 IF '$DATA(^PS(FI,RX,0))
QUIT
SET RX0=^(0)
+4 IF $PIECE(RX0,"^",3)["NW"!($PIECE(RX0,"^",3)="DC")
IF $PIECE(RX0,"^",24)
SET ORD=$PIECE(RX0,"^")
DO GETD
End DoDot:2
End DoDot:1
+5 QUIT
GETD ;
+1 IF $GET(PSDPT)
GOTO GETD1
+2 IF '$DATA(PAT($PIECE(RX0,"^",2)))
QUIT
GETD1 ;
+1 DO GETDATA^ORWOR1(.Y,ORD,$PIECE(RX0,"^",2))
IF Y<0
QUIT
IF $GET(PND)
Begin DoDot:1
+2 SET Y=Y_"^"_$PIECE(RX0,"^",3)
+3 IF $PIECE(RX0,"^",3)="DC"
IF $GET(^PS(52.41,RX,4))]""
Begin DoDot:2
+4 SET Y=Y_"^"_$TRANSLATE(^PS(52.41,RX,4),":",",")
SET $PIECE(Y,"^",4)="5;DISCONTINUED"
End DoDot:2
End DoDot:1
+5 DO CONT
+6 QUIT
CONT ;
+1 SET ORS=+$PIECE(Y,"^",4)
IF 'ORS!('PSDXF&(ORS=7))
QUIT
+2 IF 'PSDDF&(",1,12,13,"[(","_ORS_","))
QUIT
+3 SET S1=$SELECT(ORS=5:4,ORS=7:3,",1,12,13,"[(","_ORS_","):2,1:1)
+4 SET PAT=$PIECE($GET(Y(1)),"^")
IF PAT=""
QUIT
+5 SET DRUG=$SELECT($PIECE($GET(Y(2)),"^")]"":$PIECE(Y(2),"^"),$PIECE($GET(Y(6)),"^")]"":$PIECE(Y(6),"^"),1:"")
+6 IF $GET(PSDRG)
GOTO CT1
+7 IF '$DATA(DRG($PIECE(Y(2),"^",2)))
QUIT
CT1 SET PROV=$PIECE($GET(Y(4)),"^")
IF PROV=""
QUIT
+1 IF $GET(PSDPR)
GOTO CT2
+2 IF '$DATA(PRO($PIECE(Y(4),"^",2)))
QUIT
CT2 SET SCH=$PIECE($GET(Y(2)),"^",5)
IF SCH=""
QUIT
+1 IF $GET(PSDSC)
GOTO CT3
+2 IF '$DATA(SCH($PIECE(Y(2),"^",5)))
QUIT
CT3 IF NS=4
Begin DoDot:1
+1 SET ^TMP($JOB,S1,@(SR(1)),@(SR(2)),@(SR(3)),@(SR(4)),RX,0)=Y
SET I=0
+2 FOR
SET I=$ORDER(Y(I))
IF 'I
QUIT
SET ^TMP($JOB,S1,@(SR(1)),@(SR(2)),@(SR(3)),@(SR(4)),RX,I)=Y(I)
End DoDot:1
QUIT
+3 IF NS=3
Begin DoDot:1
+4 SET ^TMP($JOB,S1,@(SR(1)),@(SR(2)),@(SR(3)),RX,0)=Y
SET I=0
+5 FOR
SET I=$ORDER(Y(I))
IF 'I
QUIT
SET ^TMP($JOB,S1,@(SR(1)),@(SR(2)),@(SR(3)),RX,I)=Y(I)
End DoDot:1
QUIT
+6 IF NS=2
Begin DoDot:1
+7 SET ^TMP($JOB,S1,@(SR(1)),@(SR(2)),RX,0)=Y
SET I=0
+8 FOR
SET I=$ORDER(Y(I))
IF 'I
QUIT
SET ^TMP($JOB,S1,@(SR(1)),@(SR(2)),RX,I)=Y(I)
End DoDot:1
QUIT
+9 SET ^TMP($JOB,S1,@(SR(1)),RX,0)=Y
SET I=0
+10 FOR
SET I=$ORDER(Y(I))
IF 'I
QUIT
SET ^TMP($JOB,S1,@(SR(1)),RX,I)=Y(I)
+11 QUIT
+12 ;
PSTR DO NOW^%DTC
SET TDT=$EXTRACT(%,4,5)_"/"_$EXTRACT(%,6,7)_"/"_$EXTRACT(%,2,3)_"@"_$EXTRACT(%,9,10)_":"_$EXTRACT(%,11,12)
+1 NEW P1,P2
SET $EXTRACT(P1,42)=""
SET $EXTRACT(P2,12)=""
SET PG=1
SET Y=PSDBD
DO D^DIQ
SET BDT=Y
SET Y=PSDED
DO D^DIQ
SET EDT=Y
+2 SET DVN=$$GET1^DIQ(59,PSDDV,.01)
IF DVN]""
SET DVN=$EXTRACT(DVN,1,20)
IF DVN=""
SET DVN="N/A"
+3 USE IO
IF '$DATA(^TMP($JOB))
DO HD
WRITE !!,"********** NO DATA TO PRINT **********",!!
QUIT
+4 DO @("N"_NS)
+5 QUIT
IN KILL Y0,Y1,Y2,Y3,Y4,Y5,Y6
SET S6=""
+1 QUIT
WR SET PG=1
DO HD
WRITE !,$SELECT(AC=1:"Processed",AC=2:"Discontinued",AC=3:"Expired",1:"Pending")_" Orders:",!
QUIT
N4 SET AC=""
FOR
SET AC=$ORDER(^TMP($JOB,AC))
IF 'AC
QUIT
DO WR
Begin DoDot:1
+1 SET S1=""
FOR
SET S1=$ORDER(^TMP($JOB,AC,S1))
IF S1=""
QUIT
SET S2=""
FOR
SET S2=$ORDER(^TMP($JOB,AC,S1,S2))
IF S2=""
QUIT
Begin DoDot:2
+2 SET S3=""
FOR
SET S3=$ORDER(^TMP($JOB,AC,S1,S2,S3))
IF S3=""
QUIT
SET S4=""
FOR
SET S4=$ORDER(^TMP($JOB,AC,S1,S2,S3,S4))
IF S4=""
QUIT
Begin DoDot:3
+3 SET S5=""
FOR
SET S5=$ORDER(^TMP($JOB,AC,S1,S2,S3,S4,S5))
IF S5=""
QUIT
DO STR4
IF $DATA(DIRUT)
QUIT
End DoDot:3
IF $DATA(DIRUT)
QUIT
End DoDot:2
IF $DATA(DIRUT)
QUIT
End DoDot:1
IF $DATA(DIRUT)
QUIT
DO HD1
IF $DATA(DIRUT)
QUIT
+4 QUIT
STR4 ;
+1 DO IN
FOR
SET S6=$ORDER(^TMP($JOB,AC,S1,S2,S3,S4,S5,S6))
IF S6=""
QUIT
SET Z="Y"_S6
SET @Z=^TMP($JOB,AC,S1,S2,S3,S4,S5,S6)
+2 DO PRT
QUIT
N3 SET AC=""
FOR
SET AC=$ORDER(^TMP($JOB,AC))
IF 'AC
QUIT
DO WR
Begin DoDot:1
+1 SET S1=""
FOR
SET S1=$ORDER(^TMP($JOB,AC,S1))
IF S1=""
QUIT
SET S2=""
FOR
SET S2=$ORDER(^TMP($JOB,AC,S1,S2))
IF S2=""
QUIT
Begin DoDot:2
+2 SET S3=""
FOR
SET S3=$ORDER(^TMP($JOB,AC,S1,S2,S3))
IF S3=""
QUIT
Begin DoDot:3
+3 SET S5=""
FOR
SET S5=$ORDER(^TMP($JOB,AC,S1,S2,S3,S5))
IF S5=""
QUIT
DO STR3
IF $DATA(DIRUT)
QUIT
End DoDot:3
IF $DATA(DIRUT)
QUIT
End DoDot:2
IF $DATA(DIRUT)
QUIT
End DoDot:1
IF $DATA(DIRUT)
QUIT
DO HD1
IF $DATA(DIRUT)
QUIT
+4 QUIT
STR3 DO IN
FOR
SET S6=$ORDER(^TMP($JOB,AC,S1,S2,S3,S5,S6))
IF S6=""
QUIT
SET Z="Y"_S6
SET @Z=^TMP($JOB,AC,S1,S2,S3,S5,S6)
+1 DO PRT
QUIT
N2 SET AC=""
FOR
SET AC=$ORDER(^TMP($JOB,AC))
IF 'AC
QUIT
DO WR
Begin DoDot:1
+1 SET S1=""
FOR
SET S1=$ORDER(^TMP($JOB,AC,S1))
IF S1=""
QUIT
SET S2=""
FOR
SET S2=$ORDER(^TMP($JOB,AC,S1,S2))
IF S2=""
QUIT
Begin DoDot:2
+2 SET S5=""
FOR
SET S5=$ORDER(^TMP($JOB,AC,S1,S2,S5))
IF S5=""
QUIT
DO STR2
IF $DATA(DIRUT)
QUIT
End DoDot:2
IF $DATA(DIRUT)
QUIT
End DoDot:1
IF $DATA(DIRUT)
QUIT
DO HD1
IF $DATA(DIRUT)
QUIT
+3 QUIT
STR2 DO IN
FOR
SET S6=$ORDER(^TMP($JOB,AC,S1,S2,S5,S6))
IF S6=""
QUIT
SET Z="Y"_S6
SET @Z=^TMP($JOB,AC,S1,S2,S5,S6)
+1 DO PRT
QUIT
N1 SET AC=""
FOR
SET AC=$ORDER(^TMP($JOB,AC))
IF 'AC
QUIT
DO WR
Begin DoDot:1
+1 SET S1=""
FOR
SET S1=$ORDER(^TMP($JOB,AC,S1))
IF S1=""
QUIT
Begin DoDot:2
+2 SET S5=""
FOR
SET S5=$ORDER(^TMP($JOB,AC,S1,S5))
IF S5=""
QUIT
DO STR1
IF $DATA(DIRUT)
QUIT
End DoDot:2
IF $DATA(DIRUT)
QUIT
End DoDot:1
IF $DATA(DIRUT)
QUIT
DO HD1
IF $DATA(DIRUT)
QUIT
+3 QUIT
STR1 DO IN
FOR
SET S6=$ORDER(^TMP($JOB,AC,S1,S5,S6))
IF S6=""
QUIT
SET Z="Y"_S6
SET @Z=^TMP($JOB,AC,S1,S5,S6)
+1 DO PRT
+2 QUIT
PRT IF ($Y+4)>IOSL
DO HD
IF $DATA(DIRUT)
QUIT
DO PRT^PSDDSOR1
+1 QUIT
HD DO HD1
IF $DATA(DIRUT)
QUIT
+1 WRITE @IOF,!?2,"Digitally Signed CS Orders Report for Division "_DVN,?70,"Page: ",PG
+2 WRITE !,?8,"Date Range: "_BDT_" - "_EDT,?53,"Printed on: "_TDT,!
+3 SET PG=PG+1
+4 QUIT
HD1 IF PG>1
IF $EXTRACT(IOST)="C"
KILL DIR
SET DIR(0)="E"
SET DIR("A")=" Press Return to Continue or ^ to Exit"
DO ^DIR
KILL DIR
+1 QUIT
END WRITE !
DO ^%ZISC
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+1 KILL ^TMP($JOB),PSDDV,PSDSD,PSDED,PSDDF,PSDXF,DRG,PRO,PAT,PND,SCH,SRT,PSDRG,PSDPR,PSDPT,PSDSC,VA,Y0,Y1,Y2,Y3,Y4,Y5,Y6
KV KILL DIR,DIRUT,DTOUT,DUOUT
+1 QUIT
