- PSDDSOR ;BHM/MHA/PWC - Digitally signed CS Orders Report ;02/02/2021
- ;;3.0;CONTROLLED SUBSTANCES;**40,42,45,67,73,89**;Feb 13,1997;Build 18
- ;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
- ;Ref. to ^PSOERXU9 supported by ICR/IA 7222
- ;
- 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,PSDRXSRC
- N PSDXF,RX,RX0,RX2,S1,S2,S3,S4,S5,S6,SCH,SR,SRT,TDT,TY,I,J,O,X,Y,Z,G
- 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
- ;
- ; Prescription Source Filter Prompts - PSD-89
- K DIR S DIR(0)="S^C:CPRS (Internal);E:eRx (External - Inbound);B:Electronically Signed (CPRS+eRx);W:Written (Backdoor Pharmacy);A:ALL"
- S DIR("B")="A"
- S DIR("?")="Select the source of the CS prescription"
- S DIR("A")="Prescription Source"
- D ^DIR
- I $D(DIRUT)!$D(DTOUT) Q
- S PSDRXSRC=Y
- ;
- 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
- I $G(PSDCSRX)!(PSDRXSRC="W") S PSDPO=0 G SL ;PSD-89
- 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)
- .I Y="S" S PSDSC=0
- .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 !!,"Select controlled substance schedule(s)"
- K DIR
- S DIR(0)="S^1:"_$S($G(PSDCSRX):"SCHEDULE I - II",1:"SCHEDULE II")_";2:SCHEDULES III - V;3:SCHEDULES II - V",DIR("A")="Select Schedule(s)",DIR("B")=3
- D ^DIR I $D(DTOUT)!($D(DUOUT))!($D(DIRUT)) Q
- K SCH S I=$S($G(PSDCSRX)&(Y=1):1,Y=2:3,1:2),J=$S(Y=1:2,1:5) F K=I:1:J S SCH(K)=""
- W ! D KV
- 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="PSOSITE","PSDDV","PSDSD","PSDBD","PSDED","PSDDF","PSDXF","PSDPO","PSDRG","PSDPR","PSDPT","PSDSC","PSDRXSRC" 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("PSDDSOR",$J) S (I,NS)=0 F S I=$O(SR(I)) Q:'I S NS=I
- S PND=0,POS=PSDSD
- F S PSDSD=$O(^PSRX("AC",PSDSD)) Q:'PSDSD!(PSDSD>PSDED) D EN1
- D:PSDPO EN2 D PSTR G END
- Q
- EN1 S RX=0 F S RX=$O(^PSRX("AC",PSDSD,RX)) Q:'RX D
- .Q:'$D(^PSRX(RX,0)) Q:$P(^(2),"^",9)'=PSDDV Q:($G(PSDCSRX))&('+$P(^(2),"^",2)) S RX0=^(0),ORD=$P($G(^("OR1")),"^",2)
- .;Not a Controlled Substance Rx - PSD-89, next 4 lines
- .I '$$CSDS^PSOSIGDS(+$P(RX0,"^",6)) Q
- .I PSDRXSRC="E"!(PSDRXSRC="W"),$P($G(^PSRX(RX,"PKI")),"^",1) Q
- .I PSDRXSRC="C"!(PSDRXSRC="W"),$$ERXIEN^PSOERXU9(RX) Q
- .I PSDRXSRC'="W",PSDRXSRC'="A",'$P($G(^PSRX(RX,"PKI")),"^",1),'$$ERXIEN^PSOERXU9(RX) Q
- .Q:'$P(RX0,"^",2)!('$P(RX0,"^",4))!('$P(RX0,"^",6))!('ORD)
- .D GETD
- Q
- EN2 S DV=0,PND=1
- N PSIR,PSINST
- S PSIR=0 F S PSIR=$O(^PS(59,PSOSITE,"INI1",PSIR)) Q:'PSIR I $P($G(^PS(59,PSOSITE,"INI1",PSIR,0)),"^") S PSINST($P($G(^(0)),"^"))=""
- F S POS=$O(^PS(52.41,"AD",POS)) Q:'POS!(POS>(PSDED_".999999")) S DV=0 F S DV=$O(^PS(52.41,"AD",POS,DV)) Q:'DV D
- .S RX=0 F S RX=$O(^PS(52.41,"AD",POS,DV,RX)) Q:'RX D
- ..Q:'$D(^PS(52.41,RX,0)) S RX0=^(0)
- ..;Not a Controlled Substance Rx - PSD-89
- ..I '$$CSDS^PSOSIGDS(+$P(RX0,"^",9)) Q
- ..I PSDRXSRC="E"!(PSDRXSRC="W"),$P(RX0,"^",24) Q
- ..I PSDRXSRC="C"!(PSDRXSRC="W"),$$ERXIEN^PSOERXU9(RX_"P") Q
- ..I PSDRXSRC'="W",PSDRXSRC'="A",'$P(RX0,"^",24),'$$ERXIEN^PSOERXU9(RX_"P") Q
- ..I $P(RX0,"^",3)["NW"!($P(RX0,"^",3)="DC") I $D(PSINST($P($G(^PS(52.41,RX,"INI")),"^"))) S ORD=$P(RX0,"^") D GETD ;PSD-89 - remove check for sig stat
- Q
- GETD ;
- I $G(PSDPT) G GETD1
- Q:'$D(PAT($P(RX0,"^",2)))
- GETD1 ;
- D GETDATA^PSDDSOR1(.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)="13;DISCONTINUED"
- D CONT
- Q
- CONT ;
- S ORS=+$P(Y,"^",4) Q:ORS="" S $P(Y,"^",12)=$S($G(PND):"P",1:"R")
- S $P(Y,"^",13)=$S($G(PND):$P(RX0,"^",13),1:$P(RX0,"^",5))
- I '$P(Y,"^",10) Q:'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)
- I $P(Y,"^",10) Q:'PSDXF&(ORS=11) Q:'PSDDF&(",12,13,14,15,"[(","_ORS_",")) S S1=$S(ORS=99:4,ORS=11:3,",12,13,14,15,"[(","_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:"")
- N DRGN S DRGN=$S(+$P($G(Y(2)),"^",2):+$P(Y(2),"^",2),+$P($G(Y(6)),"^",2):+$P(Y(6),"^",2),1:"")
- G:$G(PSDRG) CT1
- Q:'$D(DRG(DRGN))
- 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="" ; check is this the DEA code?
- G:$G(PSDSC) CT3
- Q:'$D(SCH(+$P(Y(2),"^",5))) ;if schedule not selected then should include all schedules.
- CT3 I NS=4 D Q
- .S ^TMP("PSDDSOR",$J,S1,@(SR(1)),@(SR(2)),@(SR(3)),@(SR(4)),RX,0)=Y,I=0
- .F S I=$O(Y(I)) Q:'I M ^TMP("PSDDSOR",$J,S1,@(SR(1)),@(SR(2)),@(SR(3)),@(SR(4)),RX,I)=Y(I)
- I NS=3 D Q
- .S ^TMP("PSDDSOR",$J,S1,@(SR(1)),@(SR(2)),@(SR(3)),RX,0)=Y,I=0
- .F S I=$O(Y(I)) Q:'I M ^TMP("PSDDSOR",$J,S1,@(SR(1)),@(SR(2)),@(SR(3)),RX,I)=Y(I)
- I NS=2 D Q
- .S ^TMP("PSDDSOR",$J,S1,@(SR(1)),@(SR(2)),RX,0)=Y,I=0
- .F S I=$O(Y(I)) Q:'I M ^TMP("PSDDSOR",$J,S1,@(SR(1)),@(SR(2)),RX,I)=Y(I)
- S ^TMP("PSDDSOR",$J,S1,@(SR(1)),RX,0)=Y,I=0
- F S I=$O(Y(I)) Q:'I M ^TMP("PSDDSOR",$J,S1,@(SR(1)),RX,I)=Y(I)
- Q
- ;
- PSTR ;
- N %
- 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("PSDDSOR",$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("PSDDSOR",$J,AC)) Q:'AC D WR D Q:$D(DIRUT) D HD1 Q:$D(DIRUT)
- .S S1="" F S S1=$O(^TMP("PSDDSOR",$J,AC,S1)) Q:S1="" S S2="" F S S2=$O(^TMP("PSDDSOR",$J,AC,S1,S2)) Q:S2="" D Q:$D(DIRUT)
- ..S S3="" F S S3=$O(^TMP("PSDDSOR",$J,AC,S1,S2,S3)) Q:S3="" S S4="" F S S4=$O(^TMP("PSDDSOR",$J,AC,S1,S2,S3,S4)) Q:S4="" D Q:$D(DIRUT)
- ...S S5="" F S S5=$O(^TMP("PSDDSOR",$J,AC,S1,S2,S3,S4,S5)) Q:S5="" D STR4 Q:$D(DIRUT)
- Q
- STR4 ;
- D IN F S S6=$O(^TMP("PSDDSOR",$J,AC,S1,S2,S3,S4,S5,S6)) Q:S6="" S Z="Y"_S6,@Z=^TMP("PSDDSOR",$J,AC,S1,S2,S3,S4,S5,S6)
- D PRT Q
- N3 S AC="" F S AC=$O(^TMP("PSDDSOR",$J,AC)) Q:'AC D WR D Q:$D(DIRUT) D HD1 Q:$D(DIRUT)
- .S S1="" F S S1=$O(^TMP("PSDDSOR",$J,AC,S1)) Q:S1="" S S2="" F S S2=$O(^TMP("PSDDSOR",$J,AC,S1,S2)) Q:S2="" D Q:$D(DIRUT)
- ..S S3="" F S S3=$O(^TMP("PSDDSOR",$J,AC,S1,S2,S3)) Q:S3="" D Q:$D(DIRUT)
- ...S S5="" F S S5=$O(^TMP("PSDDSOR",$J,AC,S1,S2,S3,S5)) Q:S5="" D STR3 Q:$D(DIRUT)
- Q
- STR3 D IN F S S6=$O(^TMP("PSDDSOR",$J,AC,S1,S2,S3,S5,S6)) Q:S6="" S Z="Y"_S6 M @Z=^TMP("PSDDSOR",$J,AC,S1,S2,S3,S5,S6)
- D PRT Q
- N2 S AC="" F S AC=$O(^TMP("PSDDSOR",$J,AC)) Q:'AC D WR D Q:$D(DIRUT) D HD1 Q:$D(DIRUT)
- .S S1="" F S S1=$O(^TMP("PSDDSOR",$J,AC,S1)) Q:S1="" S S2="" F S S2=$O(^TMP("PSDDSOR",$J,AC,S1,S2)) Q:S2="" D Q:$D(DIRUT)
- ..S S5="" F S S5=$O(^TMP("PSDDSOR",$J,AC,S1,S2,S5)) Q:S5="" D STR2 Q:$D(DIRUT)
- Q
- STR2 D IN F S S6=$O(^TMP("PSDDSOR",$J,AC,S1,S2,S5,S6)) Q:S6="" S Z="Y"_S6 M @Z=^TMP("PSDDSOR",$J,AC,S1,S2,S5,S6)
- D PRT Q
- N1 S AC="" F S AC=$O(^TMP("PSDDSOR",$J,AC)) Q:'AC D WR D Q:$D(DIRUT) D HD1 Q:$D(DIRUT)
- .S S1="" F S S1=$O(^TMP("PSDDSOR",$J,AC,S1)) Q:S1="" D Q:$D(DIRUT)
- ..S S5="" F S S5=$O(^TMP("PSDDSOR",$J,AC,S1,S5)) Q:S5="" D STR1 Q:$D(DIRUT)
- Q
- STR1 D IN F S S6=$O(^TMP("PSDDSOR",$J,AC,S1,S5,S6)) Q:S6="" S Z="Y"_S6 M @Z=^TMP("PSDDSOR",$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,!,"OP "_$S(PSDRXSRC'="W"&(PSDRXSRC'="A"):"Digitally Signed ",1:"")_"CS Orders Report for Division "_DVN,?71,"Page: ",$J(PG,3) ;PSD-89
- W !,"Date Range: "_$$FMTE^XLFDT(PSDBD,"2Y")_" - "_$$FMTE^XLFDT(PSDED,"2Y")
- W ?33,"Source: ",$S(PSDRXSRC="C":"CPRS",PSDRXSRC="E":"eRx",PSDRXSRC="B":"CPRS+eRx",PSDRXSRC="W":"WRITTEN",1:"ALL")
- W ?54,"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("PSDDSOR",$J),PSDDV,PSDSD,PSDED,PSDDF,PSDXF,DRG,PRO,PAT,PND,SCH,SRT,PSDRG,PSDPR,PSDPT,PSDSC,VA,Y0,Y1,Y2,Y3,Y4,Y5,Y6,I,J,K,PSDCSRX
- KV K DIR,DIRUT,DTOUT,DUOUT
- Q
- ;
- INST ;
- N PSIR
- S PSIR=0 F S PSIR=$O(^PS(59,PSOSITE,"INI1",PSIR)) Q:'PSIR I $P($G(^PS(59,PSOSITE,"INI1",PSIR,0)),"^") S PSINST($P($G(^(0)),"^"))=""
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDDSOR 12024 printed Feb 18, 2025@23:11:56 Page 2
- PSDDSOR ;BHM/MHA/PWC - Digitally signed CS Orders Report ;02/02/2021
- +1 ;;3.0;CONTROLLED SUBSTANCES;**40,42,45,67,73,89**;Feb 13,1997;Build 18
- +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 ;Ref. to ^PSOERXU9 supported by ICR/IA 7222
- +8 ;
- +9 NEW AC,BDT,CT,DFN,DP,DRG,DRUG,DV,DVN,EDT,FI,NS,OP,ORD,ORS,PAT,PG,POS,PL,PL1,PRO,PROV
- +10 NEW PSDBD,PSDDF,PSDDV,PSDED,PSDIO,PSDPO,PSDPR,PSDPT,PSDRG,PSDSC,PSDSD,PSDRXSRC
- +11 NEW PSDXF,RX,RX0,RX2,S1,S2,S3,S4,S5,S6,SCH,SR,SRT,TDT,TY,I,J,O,X,Y,Z,G
- +12 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 ;
- +7 ; Prescription Source Filter Prompts - PSD-89
- +8 KILL DIR
- SET DIR(0)="S^C:CPRS (Internal);E:eRx (External - Inbound);B:Electronically Signed (CPRS+eRx);W:Written (Backdoor Pharmacy);A:ALL"
- +9 SET DIR("B")="A"
- +10 SET DIR("?")="Select the source of the CS prescription"
- +11 SET DIR("A")="Prescription Source"
- +12 DO ^DIR
- +13 IF $DATA(DIRUT)!$DATA(DTOUT)
- QUIT
- +14 SET PSDRXSRC=Y
- +15 ;
- +16 WRITE !
- DO KV
- SET DIR("A")="Include discontinued orders"
- SET DIR(0)="Y"
- SET DIR("B")="NO"
- +17 DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- GOTO END
- SET PSDDF=Y
- +18 WRITE !
- SET DIR("A")="Include expired orders"
- SET DIR(0)="Y"
- SET DIR("B")="NO"
- DO ^DIR
- +19 KILL DIR
- if $DATA(DIRUT)
- GOTO END
- SET PSDXF=Y
- +20 ;PSD-89
- IF $GET(PSDCSRX)!(PSDRXSRC="W")
- SET PSDPO=0
- GOTO SL
- +21 WRITE !
- SET DIR("A")="Include pending orders"
- SET DIR(0)="Y"
- SET DIR("B")="NO"
- DO ^DIR
- +22 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 IF Y="S"
- SET PSDSC=0
- +7 SET O=""
- FOR I=1:1:$LENGTH(OP,";")
- SET J=$PIECE(OP,";",I)
- IF J'[Y(0)
- SET O=O_$SELECT(O="":"",1:";")_J
- +8 SET OP=O
- +9 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, ")
- +10 DO @Y
- End DoDot:1
- if OP=""!($DATA(DUOUT))!($DATA(DTOUT))!($DATA(DIRUT))
- QUIT
- +11 if $DATA(DUOUT)!($DATA(DTOUT))
- GOTO END
- +12 IF $DATA(SRT)
- KILL SR
- SET I=""
- Begin DoDot:1
- +13 WRITE !!,"You have selected the following:",!
- +14 FOR
- SET I=$ORDER(SRT(I))
- if I=""
- QUIT
- Begin DoDot:2
- +15 SET J=SRT(I)
- SET SR(I)=$SELECT(J="D":"DRUG",J="PR":"PROV",J="PA":"PAT",1:"SCH")
- +16 WRITE !?5,$SELECT(J="D":"Drug",J="PR":"Provider",J="PA":"Patient",1:"Schedule")
- End DoDot:2
- +17 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
- +18 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 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)"
- +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 !!,"Select controlled substance schedule(s)"
- +2 KILL DIR
- +3 SET DIR(0)="S^1:"_$SELECT($GET(PSDCSRX):"SCHEDULE I - II",1:"SCHEDULE II")_";2:SCHEDULES III - V;3:SCHEDULES II - V"
- SET DIR("A")="Select Schedule(s)"
- SET DIR("B")=3
- +4 DO ^DIR
- IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))
- QUIT
- +5 KILL SCH
- SET I=$SELECT($GET(PSDCSRX)&(Y=1):1,Y=2:3,1:2)
- SET J=$SELECT(Y=1:2,1:5)
- FOR K=I:1:J
- SET SCH(K)=""
- +6 WRITE !
- DO KV
- +7 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="PSOSITE","PSDDV","PSDSD","PSDBD","PSDED","PSDDF","PSDXF","PSDPO","PSDRG","PSDPR","PSDPT","PSDSC","PSDRXSRC"
- 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("PSDDSOR",$JOB)
- SET (I,NS)=0
- FOR
- SET I=$ORDER(SR(I))
- if 'I
- QUIT
- SET NS=I
- +2 SET PND=0
- SET POS=PSDSD
- +3 FOR
- SET PSDSD=$ORDER(^PSRX("AC",PSDSD))
- if 'PSDSD!(PSDSD>PSDED)
- QUIT
- DO EN1
- +4 if PSDPO
- DO EN2
- DO PSTR
- GOTO END
- +5 QUIT
- EN1 SET RX=0
- FOR
- SET RX=$ORDER(^PSRX("AC",PSDSD,RX))
- if 'RX
- QUIT
- Begin DoDot:1
- +1 if '$DATA(^PSRX(RX,0))
- QUIT
- if $PIECE(^(2),"^",9)'=PSDDV
- QUIT
- if ($GET(PSDCSRX))&('+$PIECE(^(2),"^",2))
- QUIT
- SET RX0=^(0)
- SET ORD=$PIECE($GET(^("OR1")),"^",2)
- +2 ;Not a Controlled Substance Rx - PSD-89, next 4 lines
- +3 IF '$$CSDS^PSOSIGDS(+$PIECE(RX0,"^",6))
- QUIT
- +4 IF PSDRXSRC="E"!(PSDRXSRC="W")
- IF $PIECE($GET(^PSRX(RX,"PKI")),"^",1)
- QUIT
- +5 IF PSDRXSRC="C"!(PSDRXSRC="W")
- IF $$ERXIEN^PSOERXU9(RX)
- QUIT
- +6 IF PSDRXSRC'="W"
- IF PSDRXSRC'="A"
- IF '$PIECE($GET(^PSRX(RX,"PKI")),"^",1)
- IF '$$ERXIEN^PSOERXU9(RX)
- QUIT
- +7 if '$PIECE(RX0,"^",2)!('$PIECE(RX0,"^",4))!('$PIECE(RX0,"^",6))!('ORD)
- QUIT
- +8 DO GETD
- End DoDot:1
- +9 QUIT
- EN2 SET DV=0
- SET PND=1
- +1 NEW PSIR,PSINST
- +2 SET PSIR=0
- FOR
- SET PSIR=$ORDER(^PS(59,PSOSITE,"INI1",PSIR))
- if 'PSIR
- QUIT
- IF $PIECE($GET(^PS(59,PSOSITE,"INI1",PSIR,0)),"^")
- SET PSINST($PIECE($GET(^(0)),"^"))=""
- +3 FOR
- SET POS=$ORDER(^PS(52.41,"AD",POS))
- if 'POS!(POS>(PSDED_".999999"))
- QUIT
- SET DV=0
- FOR
- SET DV=$ORDER(^PS(52.41,"AD",POS,DV))
- if 'DV
- QUIT
- Begin DoDot:1
- +4 SET RX=0
- FOR
- SET RX=$ORDER(^PS(52.41,"AD",POS,DV,RX))
- if 'RX
- QUIT
- Begin DoDot:2
- +5 if '$DATA(^PS(52.41,RX,0))
- QUIT
- SET RX0=^(0)
- +6 ;Not a Controlled Substance Rx - PSD-89
- +7 IF '$$CSDS^PSOSIGDS(+$PIECE(RX0,"^",9))
- QUIT
- +8 IF PSDRXSRC="E"!(PSDRXSRC="W")
- IF $PIECE(RX0,"^",24)
- QUIT
- +9 IF PSDRXSRC="C"!(PSDRXSRC="W")
- IF $$ERXIEN^PSOERXU9(RX_"P")
- QUIT
- +10 IF PSDRXSRC'="W"
- IF PSDRXSRC'="A"
- IF '$PIECE(RX0,"^",24)
- IF '$$ERXIEN^PSOERXU9(RX_"P")
- QUIT
- +11 ;PSD-89 - remove check for sig stat
- IF $PIECE(RX0,"^",3)["NW"!($PIECE(RX0,"^",3)="DC")
- IF $DATA(PSINST($PIECE($GET(^PS(52.41,RX,"INI")),"^")))
- SET ORD=$PIECE(RX0,"^")
- DO GETD
- End DoDot:2
- End DoDot:1
- +12 QUIT
- GETD ;
- +1 IF $GET(PSDPT)
- GOTO GETD1
- +2 if '$DATA(PAT($PIECE(RX0,"^",2)))
- QUIT
- GETD1 ;
- +1 DO GETDATA^PSDDSOR1(.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)="13;DISCONTINUED"
- End DoDot:2
- End DoDot:1
- +5 DO CONT
- +6 QUIT
- CONT ;
- +1 SET ORS=+$PIECE(Y,"^",4)
- if ORS=""
- QUIT
- SET $PIECE(Y,"^",12)=$SELECT($GET(PND):"P",1:"R")
- +2 SET $PIECE(Y,"^",13)=$SELECT($GET(PND):$PIECE(RX0,"^",13),1:$PIECE(RX0,"^",5))
- +3 IF '$PIECE(Y,"^",10)
- if 'PSDXF&(ORS=7)
- QUIT
- if 'PSDDF&(",1,12,13,"[(","_ORS_","))
- QUIT
- SET S1=$SELECT(ORS=5:4,ORS=7:3,",1,12,13,"[(","_ORS_","):2,1:1)
- +4 IF $PIECE(Y,"^",10)
- if 'PSDXF&(ORS=11)
- QUIT
- if 'PSDDF&(",12,13,14,15,"[(","_ORS_","))
- QUIT
- SET S1=$SELECT(ORS=99:4,ORS=11:3,",12,13,14,15,"[(","_ORS_","):2,1:1)
- +5 SET PAT=$PIECE($GET(Y(1)),"^")
- if PAT=""
- QUIT
- +6 SET DRUG=$SELECT($PIECE($GET(Y(2)),"^")]"":$PIECE(Y(2),"^"),$PIECE($GET(Y(6)),"^")]"":$PIECE(Y(6),"^"),1:"")
- +7 NEW DRGN
- SET DRGN=$SELECT(+$PIECE($GET(Y(2)),"^",2):+$PIECE(Y(2),"^",2),+$PIECE($GET(Y(6)),"^",2):+$PIECE(Y(6),"^",2),1:"")
- +8 if $GET(PSDRG)
- GOTO CT1
- +9 if '$DATA(DRG(DRGN))
- 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 ; check is this the DEA code?
- SET SCH=$PIECE($GET(Y(2)),"^",5)
- if SCH=""
- QUIT
- +1 if $GET(PSDSC)
- GOTO CT3
- +2 ;if schedule not selected then should include all schedules.
- if '$DATA(SCH(+$PIECE(Y(2),"^",5)))
- QUIT
- CT3 IF NS=4
- Begin DoDot:1
- +1 SET ^TMP("PSDDSOR",$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
- MERGE ^TMP("PSDDSOR",$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("PSDDSOR",$JOB,S1,@(SR(1)),@(SR(2)),@(SR(3)),RX,0)=Y
- SET I=0
- +5 FOR
- SET I=$ORDER(Y(I))
- if 'I
- QUIT
- MERGE ^TMP("PSDDSOR",$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("PSDDSOR",$JOB,S1,@(SR(1)),@(SR(2)),RX,0)=Y
- SET I=0
- +8 FOR
- SET I=$ORDER(Y(I))
- if 'I
- QUIT
- MERGE ^TMP("PSDDSOR",$JOB,S1,@(SR(1)),@(SR(2)),RX,I)=Y(I)
- End DoDot:1
- QUIT
- +9 SET ^TMP("PSDDSOR",$JOB,S1,@(SR(1)),RX,0)=Y
- SET I=0
- +10 FOR
- SET I=$ORDER(Y(I))
- if 'I
- QUIT
- MERGE ^TMP("PSDDSOR",$JOB,S1,@(SR(1)),RX,I)=Y(I)
- +11 QUIT
- +12 ;
- PSTR ;
- +1 NEW %
- +2 DO NOW^%DTC
- SET TDT=$EXTRACT(%,4,5)_"/"_$EXTRACT(%,6,7)_"/"_$EXTRACT(%,2,3)_"@"_$EXTRACT(%,9,10)_":"_$EXTRACT(%,11,12)
- +3 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
- +4 SET DVN=$$GET1^DIQ(59,PSDDV,.01)
- if DVN]""
- SET DVN=$EXTRACT(DVN,1,20)
- if DVN=""
- SET DVN="N/A"
- +5 USE IO
- IF '$DATA(^TMP("PSDDSOR",$JOB))
- DO HD
- WRITE !!,"********** NO DATA TO PRINT **********",!!
- QUIT
- +6 DO @("N"_NS)
- +7 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("PSDDSOR",$JOB,AC))
- if 'AC
- QUIT
- DO WR
- Begin DoDot:1
- +1 SET S1=""
- FOR
- SET S1=$ORDER(^TMP("PSDDSOR",$JOB,AC,S1))
- if S1=""
- QUIT
- SET S2=""
- FOR
- SET S2=$ORDER(^TMP("PSDDSOR",$JOB,AC,S1,S2))
- if S2=""
- QUIT
- Begin DoDot:2
- +2 SET S3=""
- FOR
- SET S3=$ORDER(^TMP("PSDDSOR",$JOB,AC,S1,S2,S3))
- if S3=""
- QUIT
- SET S4=""
- FOR
- SET S4=$ORDER(^TMP("PSDDSOR",$JOB,AC,S1,S2,S3,S4))
- if S4=""
- QUIT
- Begin DoDot:3
- +3 SET S5=""
- FOR
- SET S5=$ORDER(^TMP("PSDDSOR",$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("PSDDSOR",$JOB,AC,S1,S2,S3,S4,S5,S6))
- if S6=""
- QUIT
- SET Z="Y"_S6
- SET @Z=^TMP("PSDDSOR",$JOB,AC,S1,S2,S3,S4,S5,S6)
- +2 DO PRT
- QUIT
- N3 SET AC=""
- FOR
- SET AC=$ORDER(^TMP("PSDDSOR",$JOB,AC))
- if 'AC
- QUIT
- DO WR
- Begin DoDot:1
- +1 SET S1=""
- FOR
- SET S1=$ORDER(^TMP("PSDDSOR",$JOB,AC,S1))
- if S1=""
- QUIT
- SET S2=""
- FOR
- SET S2=$ORDER(^TMP("PSDDSOR",$JOB,AC,S1,S2))
- if S2=""
- QUIT
- Begin DoDot:2
- +2 SET S3=""
- FOR
- SET S3=$ORDER(^TMP("PSDDSOR",$JOB,AC,S1,S2,S3))
- if S3=""
- QUIT
- Begin DoDot:3
- +3 SET S5=""
- FOR
- SET S5=$ORDER(^TMP("PSDDSOR",$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("PSDDSOR",$JOB,AC,S1,S2,S3,S5,S6))
- if S6=""
- QUIT
- SET Z="Y"_S6
- MERGE @Z=^TMP("PSDDSOR",$JOB,AC,S1,S2,S3,S5,S6)
- +1 DO PRT
- QUIT
- N2 SET AC=""
- FOR
- SET AC=$ORDER(^TMP("PSDDSOR",$JOB,AC))
- if 'AC
- QUIT
- DO WR
- Begin DoDot:1
- +1 SET S1=""
- FOR
- SET S1=$ORDER(^TMP("PSDDSOR",$JOB,AC,S1))
- if S1=""
- QUIT
- SET S2=""
- FOR
- SET S2=$ORDER(^TMP("PSDDSOR",$JOB,AC,S1,S2))
- if S2=""
- QUIT
- Begin DoDot:2
- +2 SET S5=""
- FOR
- SET S5=$ORDER(^TMP("PSDDSOR",$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("PSDDSOR",$JOB,AC,S1,S2,S5,S6))
- if S6=""
- QUIT
- SET Z="Y"_S6
- MERGE @Z=^TMP("PSDDSOR",$JOB,AC,S1,S2,S5,S6)
- +1 DO PRT
- QUIT
- N1 SET AC=""
- FOR
- SET AC=$ORDER(^TMP("PSDDSOR",$JOB,AC))
- if 'AC
- QUIT
- DO WR
- Begin DoDot:1
- +1 SET S1=""
- FOR
- SET S1=$ORDER(^TMP("PSDDSOR",$JOB,AC,S1))
- if S1=""
- QUIT
- Begin DoDot:2
- +2 SET S5=""
- FOR
- SET S5=$ORDER(^TMP("PSDDSOR",$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("PSDDSOR",$JOB,AC,S1,S5,S6))
- if S6=""
- QUIT
- SET Z="Y"_S6
- MERGE @Z=^TMP("PSDDSOR",$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 ;PSD-89
- WRITE @IOF,!,"OP "_$SELECT(PSDRXSRC'="W"&(PSDRXSRC'="A"):"Digitally Signed ",1:"")_"CS Orders Report for Division "_DVN,?71,"Page: ",$JUSTIFY(PG,3)
- +2 WRITE !,"Date Range: "_$$FMTE^XLFDT(PSDBD,"2Y")_" - "_$$FMTE^XLFDT(PSDED,"2Y")
- +3 WRITE ?33,"Source: ",$SELECT(PSDRXSRC="C":"CPRS",PSDRXSRC="E":"eRx",PSDRXSRC="B":"CPRS+eRx",PSDRXSRC="W":"WRITTEN",1:"ALL")
- +4 WRITE ?54,"Printed on: "_TDT,!
- +5 SET PG=PG+1
- +6 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("PSDDSOR",$JOB),PSDDV,PSDSD,PSDED,PSDDF,PSDXF,DRG,PRO,PAT,PND,SCH,SRT,PSDRG,PSDPR,PSDPT,PSDSC,VA,Y0,Y1,Y2,Y3,Y4,Y5,Y6,I,J,K,PSDCSRX
- KV KILL DIR,DIRUT,DTOUT,DUOUT
- +1 QUIT
- +2 ;
- INST ;
- +1 NEW PSIR
- +2 SET PSIR=0
- FOR
- SET PSIR=$ORDER(^PS(59,PSOSITE,"INI1",PSIR))
- if 'PSIR
- QUIT
- IF $PIECE($GET(^PS(59,PSOSITE,"INI1",PSIR,0)),"^")
- SET PSINST($PIECE($GET(^(0)),"^"))=""
- +3 QUIT