PSDPLOG1 ;BIR/JPW,LTL - CS Inspector's Log (cont'd) ;31 May 95
;;3.0;CONTROLLED SUBSTANCES;**22,28,73**;13 Feb 97;Build 8
;
;References to ^PSD(58.8, covered by DBIA2711
;References to ^PSD(58.81 are covered by DBIA2808
;References to ^PSDRUG( are covered by DBIA221
;References to ^PSI(58.16 are covered by DBIA213
;References to ^PSI(58.2( are covered by DBIA213
;
START ;compile data
K ^TMP("PSDLOG",$J) S (PSDCNT,PSDOUT)=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),"^",7),$P(^(0),"^",3)=+PSDSITE S NAOU(PSDN)="",CNT=CNT+1
I $D(ALL) F PSD=0:0 S PSD=$O(^PSD(58.8,PSD)) Q:'PSD I $D(^PSD(58.8,PSD,0)),$P(^(0),"^",2)="N",$P(^(0),"^",3)=+PSDSITE,'$P(^(0),"^",7) S NAOU(+PSD)=""
F STAT=2.99:0 S STAT=$O(^PSD(58.8,"AC",STAT)) Q:('STAT)!(STAT>5) F PSD=0:0 S PSD=$O(^PSD(58.8,"AC",STAT,PSD)) Q:'PSD D LOOP
S STAT=10 F PSD=0:0 S PSD=$O(^PSD(58.8,"AC",STAT,PSD)) Q:'PSD D LOOP
;PSD*3*28 22JUN00 (DAVE BLOCKER) ;perpetual Inventory
S STAT=13 F PSD=0:0 S PSD=$O(^PSD(58.8,"AC",STAT,PSD)) Q:'PSD I $P($G(^PSD(58.8,+PSD,2)),"^",5)'="" D LOOP
I $G(PSDRET) F PSDN=PSDSD:0 S PSDN=$O(^PSD(58.81,"ACT",PSDN)) Q:'PSDN!(PSDOUT) F JJ=0:0 S JJ=$O(^PSD(58.81,"ACT",PSDN,JJ)) Q:'JJ!(PSDOUT) D
.F PSDR=0:0 S PSDR=$O(^PSD(58.81,"ACT",PSDN,JJ,PSDR)) Q:'PSDR!(PSDOUT) F PSDA=0:0 S PSDA=$O(^PSD(58.81,"ACT",PSDN,JJ,PSDR,3,PSDA)) Q:'PSDA!(PSDOUT) S PSDOK="#" D
..Q:'$D(^PSD(58.81,+PSDA,0)) S NODE=^PSD(58.81,PSDA,0),NODE3=$G(^(3))
..S DEA=+$P($G(^PSDRUG(+PSDR,0)),"^",3) I '$D(PSDSCH(DEA)) Q
..S PSDRN=$S($P($G(^PSDRUG(+PSDR,0)),"^")]"":$P(^(0),"^"),1:"ZZ"_PSDR)
..S PSD=+$P(NODE,"^",18) Q:'$D(NAOU(PSD))
..S PSDNA=$S($P($G(^PSD(58.8,+PSD,0)),"^")]"":$P(^(0),"^"),1:"ZZ/"_PSD)
..S NUM=$S($P(NODE,"^",17)]"":$P(NODE,"^",17),1:"UNKNOWN"),QTY=+$P(NODE3,"^",2),EXP=$P(NODE,"^",15),EXPD="" I EXP S Y=EXP X ^DD("DD") S EXPD=Y
..S Y=$E(PSDN,1,7) X ^DD("DD") S PSDDT=Y
..D SET
G:$D(ZTQUEUED) PRTQUE
I ASKN G PRINT^PSDPLOG3 Q
G PRINT^PSDPLOG2
Q
PRTQUE ;queues print after compile
K ZTSAVE,ZTIO S ZTIO=PSDIO,ZTRTN=$S(ASKN:"PRINT^PSDPLOG3",1:"PRINT^PSDPLOG2"),ZTDESC="Print Narcotic Inspector Log",ZTDTH=$H
S (ZTSAVE("^TMP(""PSDLOG"",$J,"),ZTSAVE("CNT"),ZTSAVE("ASK"),ZTSAVE("ASKN"))=""
D ^%ZTLOAD K ^TMP("PSDLOG",$J),ZTSK
END K %,%DT,%H,%I,%ZIS,ALL,ASK,ASKN,CNT,DA,DIC,DIE,DIR,DIROUT,DIRUT,DR,DTOUT,DUOUT,EXP,EXPD,JJ,NAOU,NODE,NODE3,NUM,DEA,PSDSCH
K OK,PSD,PSDA,PSDCNT,PSDDT,PSDG,PSDIO,PSDOK,PSDOUT,PSDN,PSDNA,PSDPT,PSDR,PSDRN,PSDRD,PSDRDT,PSDRET,PSDSD,PSDST,PSDT,PSDTR
K QTY,SEL,STAT,STATN,TYP,TYPN,X,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
K ^TMP("PSDLOG",$J) D ^%ZISC
S:$D(ZTQUEUED) ZTREQ="@"
Q
LOOP ;starts drug loop
N DEA
F PSDR=0:0 S PSDR=$O(^PSD(58.8,"AC",STAT,PSD,PSDR)) Q:'PSDR D
.S DEA=+$P($G(^PSDRUG(PSDR,0)),"^",3) I '$D(PSDSCH(DEA)) Q
.F PSDA=0:0 S PSDA=$O(^PSD(58.8,"AC",STAT,PSD,PSDR,PSDA)) Q:'PSDA I $D(^PSD(58.8,PSD,1,PSDR,3,PSDA,0)) S NODE=^PSD(58.8,PSD,1,PSDR,3,PSDA,0) D
..;DAVE B (PSD*3*22) Check for matching ORDER STATUSs
..;First check 58.8's order node for status inconsistency
..S STAT1=$P(NODE,"^",11),STAT2=$P(NODE,"^",12)
..I ($G(STAT1)=6)!($G(STAT1)=7)!($G(STAT1)=8)!($G(STAT1)=9)!($G(STAT1)=11)!($G(STAT1)=12) Q
..I $G(STAT2)>0 Q
..;Then check the transaction file for matching status.
..Q:'$D(NAOU(PSD)) S PSDNA=$S($P($G(^PSD(58.8,+PSD,0)),"^")]"":$P(^(0),"^"),1:"ZZ/"_PSD)
..S PSDOK=$S(STAT=3:"**",STAT=10:"*",1:""),PSDTR=$P(NODE,"^",17) I STAT=10 Q:$D(^PSD(58.81,"AE",PSDTR))
..S PSDRN=$S($P($G(^PSDRUG(PSDR,0)),"^")]"":$P(^(0),"^"),1:"ZZ/"_PSDR),STAT1=+$P(NODE,"^",11),STATN=$S($P($G(^PSD(58.82,STAT1,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
..S QTY=$P(NODE,"^",19),NUM=$S($P(NODE,"^",16)]"":$P(NODE,"^",16),1:"UNKNOWN"),EXP=$P(NODE,"^",10),EXPD="" I EXP S Y=EXP X ^DD("DD") S EXPD=Y
..S PSDST=$P(NODE,"^",14),PSDDT="" I PSDST S Y=$E(PSDST,1,7) X ^DD("DD") S PSDDT=Y
..D SET
Q
SET ;sets ^tmp
S PSDCNT=PSDCNT+1
I ASKN D LOOP0 Q
S:ASK="D" ^TMP("PSDLOG",$J,PSDNA,PSDRN,NUM,PSDCNT)=QTY_"^"_PSDDT_"^"_EXPD_"^"_PSDOK_"^^"_PSDR
S:ASK="N" ^TMP("PSDLOG",$J,PSDNA,NUM,PSDRN,PSDCNT)=QTY_"^"_PSDDT_"^"_EXPD_"^"_PSDOK_"^^"_PSDR
Q
LOOP0 ;sets sort for inventory type sort
I '$O(^PSD(58.8,PSD,1,PSDR,2,0)) S TYPN="ZZ** NO INVENTORY TYPE DATA **" D LOOP1 Q
;F NAOU=0:0 S NAOU=$O(NAOU(NAOU)) Q:'NAOU
F TYP=0:0 S TYP=$O(^PSD(58.8,+PSD,1,PSDR,2,TYP)) Q:'TYP S TYPN=$S($P($G(^PSI(58.16,+TYP,0)),"^")]"":$P(^(0),"^"),1:"TYPE NAME MISSING") D LOOP1
Q
LOOP1 ;S:ASK="D" ^TMP("PSDLOG",$J,PSDNA,TYPN,PSDRN,NUM,PSDCNT)=QTY_"^"_PSDDT_"^"_EXPD_"^"_PSDOK
S:'$G(TYP) TYP=999999
D:ASK="D"
.S ^TMP("PSDLOG",$J,"B",PSDNA,PSD)="",^TMP("PSDLOG",$J,PSD,+TYP)=0
.S ^TMP("PSDLOG",$J,PSD,"B",TYPN,+TYP)=""
.S ^TMP("PSDLOG",$J,PSD,+TYP,PSDR,NUM,PSDCNT)=QTY_U_PSDDT_U_EXPD_U_PSDOK
.S ^TMP("PSDLOG",$J,PSD,+TYP,"B",PSDRN,PSDR)=""
;S:ASK="N" ^TMP("PSDLOG",$J,PSDNA,TYPN,NUM,PSDRN,PSDCNT)=QTY_"^"_PSDDT_"^"_EXPD_"^"_PSDOK
D:ASK="N"
.S ^TMP("PSDLOG",$J,"B",PSDNA,PSD)="",^TMP("PSDLOG",$J,PSD,+TYP)=0
.S ^TMP("PSDLOG",$J,PSD,"B",TYPN,+TYP)=""
.S ^TMP("PSDLOG",$J,PSD,+TYP,NUM,PSDR,PSDCNT)=QTY_U_PSDDT_U_EXPD_U_PSDOK_U_PSDRN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDPLOG1 5237 printed Dec 13, 2024@01:48:04 Page 2
PSDPLOG1 ;BIR/JPW,LTL - CS Inspector's Log (cont'd) ;31 May 95
+1 ;;3.0;CONTROLLED SUBSTANCES;**22,28,73**;13 Feb 97;Build 8
+2 ;
+3 ;References to ^PSD(58.8, covered by DBIA2711
+4 ;References to ^PSD(58.81 are covered by DBIA2808
+5 ;References to ^PSDRUG( are covered by DBIA221
+6 ;References to ^PSI(58.16 are covered by DBIA213
+7 ;References to ^PSI(58.2( are covered by DBIA213
+8 ;
START ;compile data
+1 KILL ^TMP("PSDLOG",$JOB)
SET (PSDCNT,PSDOUT)=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),"^",7)
IF $PIECE(^(0),"^",3)=+PSDSITE
SET NAOU(PSDN)=""
SET CNT=CNT+1
+3 IF $DATA(ALL)
FOR PSD=0:0
SET PSD=$ORDER(^PSD(58.8,PSD))
if 'PSD
QUIT
IF $DATA(^PSD(58.8,PSD,0))
IF $PIECE(^(0),"^",2)="N"
IF $PIECE(^(0),"^",3)=+PSDSITE
IF '$PIECE(^(0),"^",7)
SET NAOU(+PSD)=""
+4 FOR STAT=2.99:0
SET STAT=$ORDER(^PSD(58.8,"AC",STAT))
if ('STAT)!(STAT>5)
QUIT
FOR PSD=0:0
SET PSD=$ORDER(^PSD(58.8,"AC",STAT,PSD))
if 'PSD
QUIT
DO LOOP
+5 SET STAT=10
FOR PSD=0:0
SET PSD=$ORDER(^PSD(58.8,"AC",STAT,PSD))
if 'PSD
QUIT
DO LOOP
+6 ;PSD*3*28 22JUN00 (DAVE BLOCKER) ;perpetual Inventory
+7 SET STAT=13
FOR PSD=0:0
SET PSD=$ORDER(^PSD(58.8,"AC",STAT,PSD))
if 'PSD
QUIT
IF $PIECE($GET(^PSD(58.8,+PSD,2)),"^",5)'=""
DO LOOP
+8 IF $GET(PSDRET)
FOR PSDN=PSDSD:0
SET PSDN=$ORDER(^PSD(58.81,"ACT",PSDN))
if 'PSDN!(PSDOUT)
QUIT
FOR JJ=0:0
SET JJ=$ORDER(^PSD(58.81,"ACT",PSDN,JJ))
if 'JJ!(PSDOUT)
QUIT
Begin DoDot:1
+9 FOR PSDR=0:0
SET PSDR=$ORDER(^PSD(58.81,"ACT",PSDN,JJ,PSDR))
if 'PSDR!(PSDOUT)
QUIT
FOR PSDA=0:0
SET PSDA=$ORDER(^PSD(58.81,"ACT",PSDN,JJ,PSDR,3,PSDA))
if 'PSDA!(PSDOUT)
QUIT
SET PSDOK="#"
Begin DoDot:2
+10 if '$DATA(^PSD(58.81,+PSDA,0))
QUIT
SET NODE=^PSD(58.81,PSDA,0)
SET NODE3=$GET(^(3))
+11 SET DEA=+$PIECE($GET(^PSDRUG(+PSDR,0)),"^",3)
IF '$DATA(PSDSCH(DEA))
QUIT
+12 SET PSDRN=$SELECT($PIECE($GET(^PSDRUG(+PSDR,0)),"^")]"":$PIECE(^(0),"^"),1:"ZZ"_PSDR)
+13 SET PSD=+$PIECE(NODE,"^",18)
if '$DATA(NAOU(PSD))
QUIT
+14 SET PSDNA=$SELECT($PIECE($GET(^PSD(58.8,+PSD,0)),"^")]"":$PIECE(^(0),"^"),1:"ZZ/"_PSD)
+15 SET NUM=$SELECT($PIECE(NODE,"^",17)]"":$PIECE(NODE,"^",17),1:"UNKNOWN")
SET QTY=+$PIECE(NODE3,"^",2)
SET EXP=$PIECE(NODE,"^",15)
SET EXPD=""
IF EXP
SET Y=EXP
XECUTE ^DD("DD")
SET EXPD=Y
+16 SET Y=$EXTRACT(PSDN,1,7)
XECUTE ^DD("DD")
SET PSDDT=Y
+17 DO SET
End DoDot:2
End DoDot:1
+18 if $DATA(ZTQUEUED)
GOTO PRTQUE
+19 IF ASKN
GOTO PRINT^PSDPLOG3
QUIT
+20 GOTO PRINT^PSDPLOG2
+21 QUIT
PRTQUE ;queues print after compile
+1 KILL ZTSAVE,ZTIO
SET ZTIO=PSDIO
SET ZTRTN=$SELECT(ASKN:"PRINT^PSDPLOG3",1:"PRINT^PSDPLOG2")
SET ZTDESC="Print Narcotic Inspector Log"
SET ZTDTH=$HOROLOG
+2 SET (ZTSAVE("^TMP(""PSDLOG"",$J,"),ZTSAVE("CNT"),ZTSAVE("ASK"),ZTSAVE("ASKN"))=""
+3 DO ^%ZTLOAD
KILL ^TMP("PSDLOG",$JOB),ZTSK
END KILL %,%DT,%H,%I,%ZIS,ALL,ASK,ASKN,CNT,DA,DIC,DIE,DIR,DIROUT,DIRUT,DR,DTOUT,DUOUT,EXP,EXPD,JJ,NAOU,NODE,NODE3,NUM,DEA,PSDSCH
+1 KILL OK,PSD,PSDA,PSDCNT,PSDDT,PSDG,PSDIO,PSDOK,PSDOUT,PSDN,PSDNA,PSDPT,PSDR,PSDRN,PSDRD,PSDRDT,PSDRET,PSDSD,PSDST,PSDT,PSDTR
+2 KILL QTY,SEL,STAT,STATN,TYP,TYPN,X,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
+3 KILL ^TMP("PSDLOG",$JOB)
DO ^%ZISC
+4 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+5 QUIT
LOOP ;starts drug loop
+1 NEW DEA
+2 FOR PSDR=0:0
SET PSDR=$ORDER(^PSD(58.8,"AC",STAT,PSD,PSDR))
if 'PSDR
QUIT
Begin DoDot:1
+3 SET DEA=+$PIECE($GET(^PSDRUG(PSDR,0)),"^",3)
IF '$DATA(PSDSCH(DEA))
QUIT
+4 FOR PSDA=0:0
SET PSDA=$ORDER(^PSD(58.8,"AC",STAT,PSD,PSDR,PSDA))
if 'PSDA
QUIT
IF $DATA(^PSD(58.8,PSD,1,PSDR,3,PSDA,0))
SET NODE=^PSD(58.8,PSD,1,PSDR,3,PSDA,0)
Begin DoDot:2
+5 ;DAVE B (PSD*3*22) Check for matching ORDER STATUSs
+6 ;First check 58.8's order node for status inconsistency
+7 SET STAT1=$PIECE(NODE,"^",11)
SET STAT2=$PIECE(NODE,"^",12)
+8 IF ($GET(STAT1)=6)!($GET(STAT1)=7)!($GET(STAT1)=8)!($GET(STAT1)=9)!($GET(STAT1)=11)!($GET(STAT1)=12)
QUIT
+9 IF $GET(STAT2)>0
QUIT
+10 ;Then check the transaction file for matching status.
+11 if '$DATA(NAOU(PSD))
QUIT
SET PSDNA=$SELECT($PIECE($GET(^PSD(58.8,+PSD,0)),"^")]"":$PIECE(^(0),"^"),1:"ZZ/"_PSD)
+12 SET PSDOK=$SELECT(STAT=3:"**",STAT=10:"*",1:"")
SET PSDTR=$PIECE(NODE,"^",17)
IF STAT=10
if $DATA(^PSD(58.81,"AE",PSDTR))
QUIT
+13 SET PSDRN=$SELECT($PIECE($GET(^PSDRUG(PSDR,0)),"^")]"":$PIECE(^(0),"^"),1:"ZZ/"_PSDR)
SET STAT1=+$PIECE(NODE,"^",11)
SET STATN=$SELECT($PIECE($GET(^PSD(58.82,STAT1,0)),"^")]"":$PIECE(^(0),"^"),1:"UNKNOWN")
+14 SET QTY=$PIECE(NODE,"^",19)
SET NUM=$SELECT($PIECE(NODE,"^",16)]"":$PIECE(NODE,"^",16),1:"UNKNOWN")
SET EXP=$PIECE(NODE,"^",10)
SET EXPD=""
IF EXP
SET Y=EXP
XECUTE ^DD("DD")
SET EXPD=Y
+15 SET PSDST=$PIECE(NODE,"^",14)
SET PSDDT=""
IF PSDST
SET Y=$EXTRACT(PSDST,1,7)
XECUTE ^DD("DD")
SET PSDDT=Y
+16 DO SET
End DoDot:2
End DoDot:1
+17 QUIT
SET ;sets ^tmp
+1 SET PSDCNT=PSDCNT+1
+2 IF ASKN
DO LOOP0
QUIT
+3 if ASK="D"
SET ^TMP("PSDLOG",$JOB,PSDNA,PSDRN,NUM,PSDCNT)=QTY_"^"_PSDDT_"^"_EXPD_"^"_PSDOK_"^^"_PSDR
+4 if ASK="N"
SET ^TMP("PSDLOG",$JOB,PSDNA,NUM,PSDRN,PSDCNT)=QTY_"^"_PSDDT_"^"_EXPD_"^"_PSDOK_"^^"_PSDR
+5 QUIT
LOOP0 ;sets sort for inventory type sort
+1 IF '$ORDER(^PSD(58.8,PSD,1,PSDR,2,0))
SET TYPN="ZZ** NO INVENTORY TYPE DATA **"
DO LOOP1
QUIT
+2 ;F NAOU=0:0 S NAOU=$O(NAOU(NAOU)) Q:'NAOU
+3 FOR TYP=0:0
SET TYP=$ORDER(^PSD(58.8,+PSD,1,PSDR,2,TYP))
if 'TYP
QUIT
SET TYPN=$SELECT($PIECE($GET(^PSI(58.16,+TYP,0)),"^")]"":$PIECE(^(0),"^"),1:"TYPE NAME MISSING")
DO LOOP1
+4 QUIT
LOOP1 ;S:ASK="D" ^TMP("PSDLOG",$J,PSDNA,TYPN,PSDRN,NUM,PSDCNT)=QTY_"^"_PSDDT_"^"_EXPD_"^"_PSDOK
+1 if '$GET(TYP)
SET TYP=999999
+2 if ASK="D"
Begin DoDot:1
+3 SET ^TMP("PSDLOG",$JOB,"B",PSDNA,PSD)=""
SET ^TMP("PSDLOG",$JOB,PSD,+TYP)=0
+4 SET ^TMP("PSDLOG",$JOB,PSD,"B",TYPN,+TYP)=""
+5 SET ^TMP("PSDLOG",$JOB,PSD,+TYP,PSDR,NUM,PSDCNT)=QTY_U_PSDDT_U_EXPD_U_PSDOK
+6 SET ^TMP("PSDLOG",$JOB,PSD,+TYP,"B",PSDRN,PSDR)=""
End DoDot:1
+7 ;S:ASK="N" ^TMP("PSDLOG",$J,PSDNA,TYPN,NUM,PSDRN,PSDCNT)=QTY_"^"_PSDDT_"^"_EXPD_"^"_PSDOK
+8 if ASK="N"
Begin DoDot:1
+9 SET ^TMP("PSDLOG",$JOB,"B",PSDNA,PSD)=""
SET ^TMP("PSDLOG",$JOB,PSD,+TYP)=0
+10 SET ^TMP("PSDLOG",$JOB,PSD,"B",TYPN,+TYP)=""
+11 SET ^TMP("PSDLOG",$JOB,PSD,+TYP,NUM,PSDR,PSDCNT)=QTY_U_PSDDT_U_EXPD_U_PSDOK_U_PSDRN
End DoDot:1
+12 QUIT
