- 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 Jan 18, 2025@02:49:31 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