PSDPWK1 ;BIR/JPW-Print Pharm Disp. Worksheet (cont'd) ; 17 Oct 93
;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
START ;compile data
K ^TMP("PSDWK",$J),^TMP("PSDWKT",$J) S PRT=0
I $D(PSDG) F PSD=0:0 S PSD=$O(PSDG(PSD)) Q:'PSD F PSDN=0:0 S PSDN=$O(^PSI(58.2,PSD,3,PSDN)) Q:'PSDN I $D(^PSD(58.8,PSDN,0)),$P(^(0),"^",4)=+PSDS S NAOU(PSDN)="",CNT=CNT+1
F JJ=0:0 S JJ=$O(^PSD(58.85,"AW",+PSDS,JJ)) Q:'JJ S JJDA=+$O(^PSD(58.85,"AW",+PSDS,JJ,0)) I JJDA D:$D(ALL)!($D(NAOU(+$P($G(^PSD(58.85,JJDA,0)),U,3))))
.K ^PSD(58.85,"AW",+PSDS,JJ,JJDA) S:$D(^PSD(58.85,JJDA,2)) ^PSD(58.85,JJDA,2)=""
F PSD=0:0 S PSD=$O(^PSD(58.85,"AE",+PSDS,PSD)) Q:'PSD I $D(^PSD(58.85,PSD,0)) S PSDN=+$P(^(0),"^",3) I $D(ALL)!$D(NAOU(PSDN)) D
.Q:+$P(^PSD(58.85,PSD,0),"^",7)>2
.S PSDNA=$S($P($G(^PSD(58.8,PSDN,0)),"^")]"":$P(^(0),"^"),1:"ZZ/"_PSDN)
.S PSDR=+$P(^PSD(58.85,PSD,0),"^",4),PSDRN=$S($P($G(^PSDRUG(PSDR,0)),"^")]"":$P(^(0),"^"),1:"ZZ/"_PSDR) S:'$D(^TMP("PSDWKT",$J,PSDRN,PSDNA)) ^TMP("PSDWKT",$J,PSDRN,PSDNA)=0
.S QTY=$P(^PSD(58.85,PSD,0),"^",6) S ^TMP("PSDWKT",$J,PSDRN,PSDNA)=^TMP("PSDWKT",$J,PSDRN,PSDNA)+QTY
.S ORD=+$P(^PSD(58.85,PSD,0),"^",12),ORDN=$S($P($G(^VA(200,ORD,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
.S COMM=$S($D(^PSD(58.85,PSD,1,0)):1,1:0)
.I (CNT=1)!(ANS="N") S ^TMP("PSDWK",$J,PSDNA,PSDRN,PSD)=QTY_"^"_ORDN_"^"_COMM
.I ANS="D",CNT'=1 S ^TMP("PSDWK",$J,PSDRN,PSDNA,PSD)=QTY_"^"_ORDN_"^"_COMM
S JJ="" F S JJ=$O(^TMP("PSDWK",$J,JJ)) Q:JJ="" S JJ1="" F S JJ1=$O(^TMP("PSDWK",$J,JJ,JJ1)) Q:JJ1="" F JJDA=0:0 S JJDA=$O(^TMP("PSDWK",$J,JJ,JJ1,JJDA)) Q:'JJDA D
.S PRT=PRT+1 K DA,DIE,DR S DIE=58.85,DA=JJDA,DR="13////"_PRT D ^DIE K DA,DIE,DR
G:'$D(ZTQUEUED) PRINT^PSDPWK2
PRTQUE ;queues print after compile
K ZTSAVE,ZTIO S ZTIO=PSDIO,ZTRTN="PRINT^PSDPWK2",ZTDESC="Print Worksheet for CS PHARM",ZTDTH=$H
S (ZTSAVE("^TMP(""PSDWK"",$J,"),ZTSAVE("^TMP(""PSDWKT"",$J,"),ZTSAVE("PSDS*"),ZTSAVE("ANS"),ZTSAVE("CNT"),ZTSAVE("SUM"))=""
D ^%ZTLOAD K ^TMP("PSDWK",$J),^TMP("PSDWKT",$J),ZTSK
END K %,%H,%I,%ZIS,ALL,ANS,C,CNT,COMM,DA,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,DUOUT,IO("Q"),JJ,JJ1,JJDA,LOOP,LOOP2,NAOU,NODE
K OK,ORD,ORDN,PG,POP,PRT,PSD,PSDCPY,PSDEV,PSDG,PSDIO,PSDN,PSDNA,PSDOUT,PSDR,PSDRN,PSDS,PSDSN,PSDT,PSDSN
K QTY,SEL,SUM,X,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK,^TMP("PSDWK",$J),^TMP("PSDWKT",$J) D ^%ZISC
S:$D(ZTQUEUED) ZTREQ="@"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDPWK1 2370 printed Nov 22, 2024@16:58:28 Page 2
PSDPWK1 ;BIR/JPW-Print Pharm Disp. Worksheet (cont'd) ; 17 Oct 93
+1 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
START ;compile data
+1 KILL ^TMP("PSDWK",$JOB),^TMP("PSDWKT",$JOB)
SET PRT=0
+2 IF $DATA(PSDG)
FOR PSD=0:0
SET PSD=$ORDER(PSDG(PSD))
if 'PSD
QUIT
FOR PSDN=0:0
SET PSDN=$ORDER(^PSI(58.2,PSD,3,PSDN))
if 'PSDN
QUIT
IF $DATA(^PSD(58.8,PSDN,0))
IF $PIECE(^(0),"^",4)=+PSDS
SET NAOU(PSDN)=""
SET CNT=CNT+1
+3 FOR JJ=0:0
SET JJ=$ORDER(^PSD(58.85,"AW",+PSDS,JJ))
if 'JJ
QUIT
SET JJDA=+$ORDER(^PSD(58.85,"AW",+PSDS,JJ,0))
IF JJDA
if $DATA(ALL)!($DATA(NAOU(+$PIECE($GET(^PSD(58.85,JJDA,0)),U,3))))
Begin DoDot:1
+4 KILL ^PSD(58.85,"AW",+PSDS,JJ,JJDA)
if $DATA(^PSD(58.85,JJDA,2))
SET ^PSD(58.85,JJDA,2)=""
End DoDot:1
+5 FOR PSD=0:0
SET PSD=$ORDER(^PSD(58.85,"AE",+PSDS,PSD))
if 'PSD
QUIT
IF $DATA(^PSD(58.85,PSD,0))
SET PSDN=+$PIECE(^(0),"^",3)
IF $DATA(ALL)!$DATA(NAOU(PSDN))
Begin DoDot:1
+6 if +$PIECE(^PSD(58.85,PSD,0),"^",7)>2
QUIT
+7 SET PSDNA=$SELECT($PIECE($GET(^PSD(58.8,PSDN,0)),"^")]"":$PIECE(^(0),"^"),1:"ZZ/"_PSDN)
+8 SET PSDR=+$PIECE(^PSD(58.85,PSD,0),"^",4)
SET PSDRN=$SELECT($PIECE($GET(^PSDRUG(PSDR,0)),"^")]"":$PIECE(^(0),"^"),1:"ZZ/"_PSDR)
if '$DATA(^TMP("PSDWKT",$JOB,PSDRN,PSDNA))
SET ^TMP("PSDWKT",$JOB,PSDRN,PSDNA)=0
+9 SET QTY=$PIECE(^PSD(58.85,PSD,0),"^",6)
SET ^TMP("PSDWKT",$JOB,PSDRN,PSDNA)=^TMP("PSDWKT",$JOB,PSDRN,PSDNA)+QTY
+10 SET ORD=+$PIECE(^PSD(58.85,PSD,0),"^",12)
SET ORDN=$SELECT($PIECE($GET(^VA(200,ORD,0)),"^")]"":$PIECE(^(0),"^"),1:"UNKNOWN")
+11 SET COMM=$SELECT($DATA(^PSD(58.85,PSD,1,0)):1,1:0)
+12 IF (CNT=1)!(ANS="N")
SET ^TMP("PSDWK",$JOB,PSDNA,PSDRN,PSD)=QTY_"^"_ORDN_"^"_COMM
+13 IF ANS="D"
IF CNT'=1
SET ^TMP("PSDWK",$JOB,PSDRN,PSDNA,PSD)=QTY_"^"_ORDN_"^"_COMM
End DoDot:1
+14 SET JJ=""
FOR
SET JJ=$ORDER(^TMP("PSDWK",$JOB,JJ))
if JJ=""
QUIT
SET JJ1=""
FOR
SET JJ1=$ORDER(^TMP("PSDWK",$JOB,JJ,JJ1))
if JJ1=""
QUIT
FOR JJDA=0:0
SET JJDA=$ORDER(^TMP("PSDWK",$JOB,JJ,JJ1,JJDA))
if 'JJDA
QUIT
Begin DoDot:1
+15 SET PRT=PRT+1
KILL DA,DIE,DR
SET DIE=58.85
SET DA=JJDA
SET DR="13////"_PRT
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
+16 if '$DATA(ZTQUEUED)
GOTO PRINT^PSDPWK2
PRTQUE ;queues print after compile
+1 KILL ZTSAVE,ZTIO
SET ZTIO=PSDIO
SET ZTRTN="PRINT^PSDPWK2"
SET ZTDESC="Print Worksheet for CS PHARM"
SET ZTDTH=$HOROLOG
+2 SET (ZTSAVE("^TMP(""PSDWK"",$J,"),ZTSAVE("^TMP(""PSDWKT"",$J,"),ZTSAVE("PSDS*"),ZTSAVE("ANS"),ZTSAVE("CNT"),ZTSAVE("SUM"))=""
+3 DO ^%ZTLOAD
KILL ^TMP("PSDWK",$JOB),^TMP("PSDWKT",$JOB),ZTSK
END KILL %,%H,%I,%ZIS,ALL,ANS,C,CNT,COMM,DA,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,DUOUT,IO("Q"),JJ,JJ1,JJDA,LOOP,LOOP2,NAOU,NODE
+1 KILL OK,ORD,ORDN,PG,POP,PRT,PSD,PSDCPY,PSDEV,PSDG,PSDIO,PSDN,PSDNA,PSDOUT,PSDR,PSDRN,PSDS,PSDSN,PSDT,PSDSN
+2 KILL QTY,SEL,SUM,X,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK,^TMP("PSDWK",$JOB),^TMP("PSDWKT",$JOB)
DO ^%ZISC
+3 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 QUIT
