PSDPAT2 ;B'ham ISC/JPW - Print Patient/Drug Report (summary) ; 1 Feb 94
;;3.0;CONTROLLED SUBSTANCES ;**68,72**;13 Feb 97;Build 8
D NOW^%DTC S Y=+$E(%,1,12) X ^DD("DD") S RPDT=Y
S (PG,PSDOUT)=0,$P(LN,"-",80)=""
I '$D(^TMP("PSDPATL",$J)) D HDR W !!,?45,"**** NO DISPENSING SUMMARY ****" Q
PRINT ;prints data for dispensing
D HDR Q:PSDOUT
S LOOP="" F S LOOP=$O(^TMP("PSDPATL",$J,LOOP)) Q:LOOP=""!(PSDOUT) D:$Y+4>IOSL HDR Q:PSDOUT D Q:PSDOUT
.W !,LOOP,?55,$J(+$P(^TMP("PSDPATL",$J,LOOP),"^",3),6),?70,$J(+$P(^(LOOP),"^",2),6),!
DONE I SUM,$E(IOST)'="C" W @IOF
Q
HDR ;lists header information
I $E(IOST,1,2)="C-",PG W ! K DA,DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSDOUT=1 Q
W:$Y @IOF S PG=PG+1 W !,?22,"ACTIVITY",?70,"PG "_PG,!,?29,"** SUMMARY **",!,?27,"Date: ",$P(PSDATE,"^")," to ",$P(PSDATE,"^",2),!!,"NAOU: ",NAOUN,!!
W "DRUG",?55,"QUANTITY USED",?70,"BALANCE",!,LN,!
Q
;; ADDED FOR 3*68 - RJS
SET ;sets data
N PSDREA
Q:'$D(^PSD(58.81,PSDA,0)) S PSD0=^(0),PSDQTY=+$P(PSD0,U,6),PSD=$P(PSD0,U,4),PSDREA=$P(PSD0,U,16)
S PSD9=$G(^PSD(58.81,PSDA,9)) S PSDSOQT=+$P(PSD9,U,3),PSDWQT=+$P(PSD9,U,4)
I +$P(PSD0,U,5) S PSDDRG1=+$P(PSD0,U,5)
I PSDTYP=17,'+$P(^PSD(58.81,PSDA,9),"^",1) D
.S PSDTYP=9,PSDQTY=PSDQTY*-1,PSDREA="DEFECTIVE DOSE"
I PSDTYP=17 S $P(PSDRG(+PSDRUG),U,2)=+$P(PSDRG(+PSDRUG),U,2)+PSDSOQT+PSDWQT
S PSD3=$G(^PSD(58.81,PSDA,3)) S PSDRET=+$P(PSD3,U),PSDRQT=+$P(PSD3,U,2),PSDRRE=$P(PSD3,U,3),PSDDQT=+$P(PSD3,U,5),PSDDRE=$P(PSD3,U,6),PSDDT=+$P(PSD3,U,4)
S DFN=+$P($G(PSD9),U) D DEM^VADPT
S PSDPAT=$S(PSDTYP=18:"WASTED AMOUNT",PSDTYP=11:"INITIALIZE BALANCE",PSDTYP=9:"BALANCE ADJUSTMENT",PSDTYP=23:"COUNT VERIFICATION",'VAERR:VADM(1),1:"UNKNOWN")
S:PSDTYP=2!(PSDTYP=3) PSDPAT="PHARMACY DISP#"_$P(PSD0,U,17),PSDTYP=0,PSDTR=PSDA
S PSDNR1=$S($P(PSD9,U,2)'="":$P(PSD9,U,2),1:$P(PSD0,U,7))
S:PSDNR1'=$P(PSD0,U,7) PSDNR1(1)=$P(PSD0,U,7)
S:+$G(PSDNR1) PSDNR1=$S($P($G(^VA(200,+PSDNR1,0)),U)]"":$P(^(0),U),1:"UNKNOWN")
S PSDNR2=$P($G(PSD9),U,6) S:PSDNR2 PSDNR2=$S($P($G(^VA(200,+PSDNR2,0)),U)]"":$P(^(0),U),1:"")
S PSDRN=$S($P($G(^PSDRUG(+PSDRUG,0)),U)]"":$P(^(0),U),1:"ZZ/"_PSDRUG_" NAME MISSING")
SET1 ;sets ^TMP("PSDPAT"
I PSDTYP=17,'+$P(^PSD(58.81,PSDA,9),"^",1) S PSDTYP=9
I $G(^PSD(58.81,PSDA,1)),$P(PSD3,U,1)'="" D CHKRET Q:PSD<PSDSD
I $P(PSD3,U,4)'="" D CHKDEST
I PSDTYP=0 D CHKNOD7
S PSDQTY=$S(PSDTYP=17:0,1:PSDQTY),PSDRQT=$S(PSDTYP=17:PSDRQT,1:-PSDRQT)
I PSD>PSDED N PSDEND S PSDEND=1
I '$G(PSDEND) D
.Q:PSD<PSDSD
.K PSDATA
.I '$D(PSDREA) N PSDREA S PSDREA=$P(PSD0,U,16)
.S PSDATA=PSDQTY_U_PSDNR1_U_PSDNR2_U_PSDTYP_U_PSDWQT_U_PSDREA_U_PSDBAL_U_$G(PSDNR1(1))_U_PSDRQT_U_PSDRRE_U_PSDDRG1_U_PSDSOQT_"^^^"_PSDRET_U_PSDDT
.S PSDCNT=PSDCNT+1 D PSDPAT,PSDPATL I $P(PSD3,U,4)'=""
I $G(PSDEND) D
.Q:PSD<PSDSD
.S PSDATA=1 D PSDPATL
I $G(PSDTRQT),PSDTFDT<PSDED D
.I '$G(PSDEND) D
..I PSD<PSDED,PSD>PSDSD S PSDATA="0^^^"_PSDTYP_"^^^"_PSDBAL_"^^^^^^^^^"_U_PSDTFDT_U_PSDNR1_U_PSDT2N_U_PSDTTDT_U_PSDTTNR_U_PSDTPRV_U_PSDTRQT_U_PSDSTAT
..S PSDQTY=PSDTRQT*-1
..N PSD S PSD=PSDTFDT,PSDCNT=PSDCNT+1 D PSDPAT,PSDPATL
. I $G(PSDEND) S PSDATA=1 D PSDPATL
.S PSDEND=$G(^TMP("PSDPAT1",$J,PSDRUG,PSDA))
I $G(PSDTRQT),(PSDTFDT>PSDED!(PSDTFDT=PSDED)) N PSDEND S PSDQTY=PSDTRQT*-1,PSDEND=1 D
.I $G(PSDEND) S PSDATA=1 D PSDPATL
K PSDATA,PSDQTY,PSDTRQT,PSDNR1,PSDNR2,PSD0,PSD3,PSD7,PSDTR Q
SET2 ;SETS ^TMP("PSDPAT"
N PSDTRDT,PSDPAT
S PSD0=$G(^PSD(58.81,PSDA,0)),PSDRN=$S($P($G(^PSDRUG(+PSDRUG,0)),U)]"":$P(^(0),U),1:"ZZ/"_PSDRUG_" NAME MISSING")
S PSDTRDT=$P(^PSD(58.81,PSDA,1),U,4),PSDPAT="PHARMACY DISP #"_$P(PSD0,U,17),PSD=$P(PSD0,U,4)
Q:$D(^TMP("PSDPAT",$J,PSDRN,PSDTRDT))
I PSDTYP=5 S PSD7=$G(^PSD(58.81,+PSDA,7)) D NODE7
S PSDTR=PSDA D
.D CHKNOD7
.I $G(PSDTRQT) D
..I PSD<PSDED,PSD>PSDSD S PSDEND=0
..I '$G(PSDEND) D
...K PSDATA
...S PSDCNT=PSDCNT+1,PSDPAT="PHARMACY DISP #"_$P(PSD0,U,17),PSDATA="^^^0^^^^^^^^^^^^^"_PSDTFDT_U_PSDTFN_U_PSDT2N_U_PSDTTDT_U_PSDTTNR_U_PSDTPRV_U_PSDTRQT_U_PSDSTAT
...D PSDPAT,PSDPATL
..S PSDEND=$G(^TMP("PSDPAT1",$J,PSDRUG,PSDA))
K PSDATA,PSDQTY,PSDTRQT,PSDNR1,PSDNR2,PSD0,PSD3,PSD7,PSDTR
Q
CHKNOD7 ; COLLECTS TRANSFER DATA
S PSD7=$G(^PSD(58.81,+PSDTR,7)) Q:$G(PSD7)=""
S PSDSTAT=$P($G(^PSD(58.81,+PSDTR,0)),U,11)
S PSDTFDT=+$P(PSD7,U),PSDTTON=+$P(PSD7,U,3),PSDT2N=$P($G(^PSD(58.8,PSDTTON,0)),U),PSDTTDT=+$P(PSD7,U,4),PSDTPRV=+$P(PSD7,U,6),PSDTRQT=+$P(PSD7,U,7)
S PSDTFN=$S($P(PSD7,U,2):$P(PSD7,U,2),1:$P(PSD0,U,7))
S:PSDTFN'=$P(PSD0,U,7) PSDTFN(1)=$P(PSD0,U,7) S PSDTFN=$S($P($G(^VA(200,+PSDTFN,0)),U)]"":$P(^(0),U),1:"UNKNOWN")
S PSDTTNR=$P($G(PSD7),U,5) S:PSDTTNR PSDTTNR=$S($P($G(^VA(200,+PSDTTNR,0)),U)]"":$P(^(0),U),1:"")
Q
NODE7 ; SETS TRANSFERS BETWEEN NAOU'S
I $P(PSD3,U,1)'="" D CHKRET Q:PSD<PSDSD
I $P(PSD3,U,4)'="" D CHKDEST Q:PSD<PSDSD
S (PSDTFDT,PSDTFN,PSDTTDT,PSDTTNR,PSDTPRV,PSDTRQT,PSDSTAT)=""
S PSDTTON=+$P(^PSD(58.81,$P(PSD7,U,6),0),U,18),PSDT2N=$P($G(^PSD(58.8,PSDTTON,0)),U),PSDTRQT=+PSDQTY
I PSD<PSDED,PSD>PSDSD S PSDEND=0
I '$G(PSDEND) D
.S PSDTFN=+$P(^PSD(58.81,$P(PSD7,U,6),7),U,2) S:PSDTFN PSDTFN=$S($P($G(^VA(200,+PSDTFN,0)),U)]"":$P(^(0),U),1:"")
.S PSDTRQT=$P(^PSD(58.81,$P(PSD7,U,6),7),U,7)
.K PSDATA S PSDATA=PSDQTY_U_PSDNR1_U_PSDNR2_U_PSDTYP_U_PSDWQT_U_$P(PSD0,U,16)_"^^"_$G(PSDNR1(1))_U_PSDRQT_U_PSDRRE
.S PSDATA=PSDATA_U_PSDDRG1_U_PSDSOQT_"^^^^^^^"_PSDT2N_U_U_PSDTFN_"^^"_PSDTRQT_U,PSDCNT=PSDCNT+1
.Q:PSD<PSDSD
.D PSDPAT,PSDPATL
.S PSDEND=$G(^TMP("PSDPAT1",$J,PSDRUG,PSDA))
I $G(PSDEND) D PSDPAT,PSDPATL
I $P(PSD7,U,1) S PSDTR=PSDA D
.D CHKNOD7
.I PSD<PSDED,PSD>PSDSD S PSDEND=0
.I '$G(PSDEND) D
..K PSDATA
..S $P(PSDATA,U,4)=PSDTYP,$P(PSDATA,U,17)=PSDTFDT,PSDATA=PSDATA_U_PSDTFN_U_PSDT2N_U_PSDTTDT_U_PSDTTNR_U_PSDTPRV_U_PSDTRQT_U_PSDSTAT
..S PSDCNT=PSDCNT+1,PSDQTY=PSDTRQT*-1 D PSDPAT,PSDPATL
.S PSDEND=$G(^TMP("PSDPAT1",$J,PSDRUG,PSDA))
I $G(PSDEND) s PSDATA=1 D PSDPATL
Q
CHKRET ; SETS RETURNED ITEM INFORMATION
N PSD,PSDNR1,PSDNR2,PSDQTY S PSD=$P(^PSD(58.81,PSDA,0),U,19),(PSDQTY,PSDWQT,PSDSOQT,PSDDQT,PSDDRE)=0
S PSDNR1=+$P(^PSD(58.81,PSDA,1),U,10),PSDNR1=$S($P($G(^VA(200,+PSDNR1,0)),U)]"":$P(^(0),U),1:"UNKNOWN")
S PSDNR2=+$P(^PSD(58.81,PSDA,1),U,14) S:PSDNR2 PSDNR2=$S($P($G(^VA(200,+PSDNR2,0)),U)]"":$P(^(0),U),1:"")
S PSDRET=+$P(PSD3,U),PSDRQT=+$P(PSD3,U,2),PSDRRE=$P(PSD3,U,3),PSDDQT=+$P(PSD3,U,5),PSDDRE=$P(PSD3,U,6),PSDDT=+$P(PSD3,U,4)
K PSDATA
S PSDQTY=PSDRQT*-1
I PSD>PSDED N PSDEND S PSDEND=1
I '$G(PSDEND) D
.I PSD<PSDED D
..S PSDATA="0^"_PSDNR1_U_PSDNR2_"^99^0^"_$P(PSD0,U,16)_"^0^^"_PSDRQT_U_PSDRRE_U_PSDDRG1_"^0^0^0^"_PSDRET
..S PSDCNT=PSDCNT+1
..D PSDPAT,PSDPATL
..S PSDRQT=0,(PSDRRE,PSDRET)=""
I $G(PSDEND) D
.Q:PSD<PSDSD
.S PSDATA=1 D PSDPATL
S PSDRQT=0,PSDRRE="" K PSDATA
Q
CHKDEST ; SETS DESTROYED ITEM INFORMATION
N PSD,PSDNR1,PSDNR2,PSDQTY S PSD=$P(PSD3,U,4)
S PSDNR1=+$P(^PSD(58.81,PSDA,1),U,10),PSDNR1=$S($P($G(^VA(200,+PSDNR1,0)),U)]"":$P(^(0),U),1:"UNKNOWN")
S PSDNR2=+$P(^PSD(58.81,PSDA,1),U,14) S:PSDNR2 PSDNR2=$S($P($G(^VA(200,+PSDNR2,0)),U)]"":$P(^(0),U),1:"")
S PSDDQT=$P(PSD3,U,5),PSDDRE=$P(PSD3,U,6) K PSDATA
I PSD>PSDED N PSDEND S PSDEND=1
I '$G(PSDEND) D
.Q:PSD<PSDSD
.S PSDATA="0^"_PSDNR1_U_PSDNR2_"^4^0^"_$P(PSD0,U,16)_"^0^^0^0^"_PSDDRG1_"^0^"_PSDDQT_U_PSDDRE
.S PSDCNT=PSDCNT+1 D PSDPAT
.S PSDQTY=PSDDQT*-1,PSDATA=1 D PSDPATL
I $G(PSDEND) S PSDQTY=PSDDQT*-1,PSDATA=1 D PSDPATL
K PSDATA
Q
PSDPAT ;sets ^TMP("PSDPAT"
Q:'$D(PSDATA)
S ^TMP("PSDPAT",$J,PSDRN,PSD,PSDPAT,PSDCNT)=PSDATA
Q
PSDPATL ;sets ^TMP("PSDPATL"
Q:'$D(PSDATA)
S:'$D(^TMP("PSDPATL",$J,PSDRN)) ^TMP("PSDPATL",$J,PSDRN)=0
S ^TMP("PSDPATL",$J,PSDRN)=+^TMP("PSDPATL",$J,PSDRN)+($S(PSDTYP=18:-PSDQTY,PSDTYP=17:-((PSDSOQT+PSDWQT)-PSDRQT),1:PSDQTY)),$P(^(PSDRN),U,2)=+PSDRG(PSDRUG)
S $P(^TMP("PSDPATL",$J,PSDRN),U,3)=+$P(^TMP("PSDPATL",$J,PSDRN),U,3)+$P(PSDRG(+PSDRUG),U,2)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDPAT2 7919 printed Apr 23, 2025@18:02:23 Page 2
PSDPAT2 ;B'ham ISC/JPW - Print Patient/Drug Report (summary) ; 1 Feb 94
+1 ;;3.0;CONTROLLED SUBSTANCES ;**68,72**;13 Feb 97;Build 8
+2 DO NOW^%DTC
SET Y=+$EXTRACT(%,1,12)
XECUTE ^DD("DD")
SET RPDT=Y
+3 SET (PG,PSDOUT)=0
SET $PIECE(LN,"-",80)=""
+4 IF '$DATA(^TMP("PSDPATL",$JOB))
DO HDR
WRITE !!,?45,"**** NO DISPENSING SUMMARY ****"
QUIT
PRINT ;prints data for dispensing
+1 DO HDR
if PSDOUT
QUIT
+2 SET LOOP=""
FOR
SET LOOP=$ORDER(^TMP("PSDPATL",$JOB,LOOP))
if LOOP=""!(PSDOUT)
QUIT
if $Y+4>IOSL
DO HDR
if PSDOUT
QUIT
Begin DoDot:1
+3 WRITE !,LOOP,?55,$JUSTIFY(+$PIECE(^TMP("PSDPATL",$JOB,LOOP),"^",3),6),?70,$JUSTIFY(+$PIECE(^(LOOP),"^",2),6),!
End DoDot:1
if PSDOUT
QUIT
DONE IF SUM
IF $EXTRACT(IOST)'="C"
WRITE @IOF
+1 QUIT
HDR ;lists header information
+1 IF $EXTRACT(IOST,1,2)="C-"
IF PG
WRITE !
KILL DA,DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET PSDOUT=1
QUIT
+2 if $Y
WRITE @IOF
SET PG=PG+1
WRITE !,?22,"ACTIVITY",?70,"PG "_PG,!,?29,"** SUMMARY **",!,?27,"Date: ",$PIECE(PSDATE,"^")," to ",$PIECE(PSDATE,"^",2),!!,"NAOU: ",NAOUN,!!
+3 WRITE "DRUG",?55,"QUANTITY USED",?70,"BALANCE",!,LN,!
+4 QUIT
+5 ;; ADDED FOR 3*68 - RJS
SET ;sets data
+1 NEW PSDREA
+2 if '$DATA(^PSD(58.81,PSDA,0))
QUIT
SET PSD0=^(0)
SET PSDQTY=+$PIECE(PSD0,U,6)
SET PSD=$PIECE(PSD0,U,4)
SET PSDREA=$PIECE(PSD0,U,16)
+3 SET PSD9=$GET(^PSD(58.81,PSDA,9))
SET PSDSOQT=+$PIECE(PSD9,U,3)
SET PSDWQT=+$PIECE(PSD9,U,4)
+4 IF +$PIECE(PSD0,U,5)
SET PSDDRG1=+$PIECE(PSD0,U,5)
+5 IF PSDTYP=17
IF '+$PIECE(^PSD(58.81,PSDA,9),"^",1)
Begin DoDot:1
+6 SET PSDTYP=9
SET PSDQTY=PSDQTY*-1
SET PSDREA="DEFECTIVE DOSE"
End DoDot:1
+7 IF PSDTYP=17
SET $PIECE(PSDRG(+PSDRUG),U,2)=+$PIECE(PSDRG(+PSDRUG),U,2)+PSDSOQT+PSDWQT
+8 SET PSD3=$GET(^PSD(58.81,PSDA,3))
SET PSDRET=+$PIECE(PSD3,U)
SET PSDRQT=+$PIECE(PSD3,U,2)
SET PSDRRE=$PIECE(PSD3,U,3)
SET PSDDQT=+$PIECE(PSD3,U,5)
SET PSDDRE=$PIECE(PSD3,U,6)
SET PSDDT=+$PIECE(PSD3,U,4)
+9 SET DFN=+$PIECE($GET(PSD9),U)
DO DEM^VADPT
+10 SET PSDPAT=$SELECT(PSDTYP=18:"WASTED AMOUNT",PSDTYP=11:"INITIALIZE BALANCE",PSDTYP=9:"BALANCE ADJUSTMENT",PSDTYP=23:"COUNT VERIFICATION",'VAERR:VADM(1),1:"UNKNOWN")
+11 if PSDTYP=2!(PSDTYP=3)
SET PSDPAT="PHARMACY DISP#"_$PIECE(PSD0,U,17)
SET PSDTYP=0
SET PSDTR=PSDA
+12 SET PSDNR1=$SELECT($PIECE(PSD9,U,2)'="":$PIECE(PSD9,U,2),1:$PIECE(PSD0,U,7))
+13 if PSDNR1'=$PIECE(PSD0,U,7)
SET PSDNR1(1)=$PIECE(PSD0,U,7)
+14 if +$GET(PSDNR1)
SET PSDNR1=$SELECT($PIECE($GET(^VA(200,+PSDNR1,0)),U)]"":$PIECE(^(0),U),1:"UNKNOWN")
+15 SET PSDNR2=$PIECE($GET(PSD9),U,6)
if PSDNR2
SET PSDNR2=$SELECT($PIECE($GET(^VA(200,+PSDNR2,0)),U)]"":$PIECE(^(0),U),1:"")
+16 SET PSDRN=$SELECT($PIECE($GET(^PSDRUG(+PSDRUG,0)),U)]"":$PIECE(^(0),U),1:"ZZ/"_PSDRUG_" NAME MISSING")
SET1 ;sets ^TMP("PSDPAT"
+1 IF PSDTYP=17
IF '+$PIECE(^PSD(58.81,PSDA,9),"^",1)
SET PSDTYP=9
+2 IF $GET(^PSD(58.81,PSDA,1))
IF $PIECE(PSD3,U,1)'=""
DO CHKRET
if PSD<PSDSD
QUIT
+3 IF $PIECE(PSD3,U,4)'=""
DO CHKDEST
+4 IF PSDTYP=0
DO CHKNOD7
+5 SET PSDQTY=$SELECT(PSDTYP=17:0,1:PSDQTY)
SET PSDRQT=$SELECT(PSDTYP=17:PSDRQT,1:-PSDRQT)
+6 IF PSD>PSDED
NEW PSDEND
SET PSDEND=1
+7 IF '$GET(PSDEND)
Begin DoDot:1
+8 if PSD<PSDSD
QUIT
+9 KILL PSDATA
+10 IF '$DATA(PSDREA)
NEW PSDREA
SET PSDREA=$PIECE(PSD0,U,16)
+11 SET PSDATA=PSDQTY_U_PSDNR1_U_PSDNR2_U_PSDTYP_U_PSDWQT_U_PSDREA_U_PSDBAL_U_$GET(PSDNR1(1))_U_PSDRQT_U_PSDRRE_U_PSDDRG1_U_PSDSOQT_"^^^"_PSDRET_U_PSDDT
+12 SET PSDCNT=PSDCNT+1
DO PSDPAT
DO PSDPATL
IF $PIECE(PSD3,U,4)'=""
End DoDot:1
+13 IF $GET(PSDEND)
Begin DoDot:1
+14 if PSD<PSDSD
QUIT
+15 SET PSDATA=1
DO PSDPATL
End DoDot:1
+16 IF $GET(PSDTRQT)
IF PSDTFDT<PSDED
Begin DoDot:1
+17 IF '$GET(PSDEND)
Begin DoDot:2
+18 IF PSD<PSDED
IF PSD>PSDSD
SET PSDATA="0^^^"_PSDTYP_"^^^"_PSDBAL_"^^^^^^^^^"_U_PSDTFDT_U_PSDNR1_U_PSDT2N_U_PSDTTDT_U_PSDTTNR_U_PSDTPRV_U_PSDTRQT_U_PSDSTAT
+19 SET PSDQTY=PSDTRQT*-1
+20 NEW PSD
SET PSD=PSDTFDT
SET PSDCNT=PSDCNT+1
DO PSDPAT
DO PSDPATL
End DoDot:2
+21 IF $GET(PSDEND)
SET PSDATA=1
DO PSDPATL
+22 SET PSDEND=$GET(^TMP("PSDPAT1",$JOB,PSDRUG,PSDA))
End DoDot:1
+23 IF $GET(PSDTRQT)
IF (PSDTFDT>PSDED!(PSDTFDT=PSDED))
NEW PSDEND
SET PSDQTY=PSDTRQT*-1
SET PSDEND=1
Begin DoDot:1
+24 IF $GET(PSDEND)
SET PSDATA=1
DO PSDPATL
End DoDot:1
+25 KILL PSDATA,PSDQTY,PSDTRQT,PSDNR1,PSDNR2,PSD0,PSD3,PSD7,PSDTR
QUIT
SET2 ;SETS ^TMP("PSDPAT"
+1 NEW PSDTRDT,PSDPAT
+2 SET PSD0=$GET(^PSD(58.81,PSDA,0))
SET PSDRN=$SELECT($PIECE($GET(^PSDRUG(+PSDRUG,0)),U)]"":$PIECE(^(0),U),1:"ZZ/"_PSDRUG_" NAME MISSING")
+3 SET PSDTRDT=$PIECE(^PSD(58.81,PSDA,1),U,4)
SET PSDPAT="PHARMACY DISP #"_$PIECE(PSD0,U,17)
SET PSD=$PIECE(PSD0,U,4)
+4 if $DATA(^TMP("PSDPAT",$JOB,PSDRN,PSDTRDT))
QUIT
+5 IF PSDTYP=5
SET PSD7=$GET(^PSD(58.81,+PSDA,7))
DO NODE7
+6 SET PSDTR=PSDA
Begin DoDot:1
+7 DO CHKNOD7
+8 IF $GET(PSDTRQT)
Begin DoDot:2
+9 IF PSD<PSDED
IF PSD>PSDSD
SET PSDEND=0
+10 IF '$GET(PSDEND)
Begin DoDot:3
+11 KILL PSDATA
+12 SET PSDCNT=PSDCNT+1
SET PSDPAT="PHARMACY DISP #"_$PIECE(PSD0,U,17)
SET PSDATA="^^^0^^^^^^^^^^^^^"_PSDTFDT_U_PSDTFN_U_PSDT2N_U_PSDTTDT_U_PSDTTNR_U_PSDTPRV_U_PSDTRQT_U_PSDSTAT
+13 DO PSDPAT
DO PSDPATL
End DoDot:3
+14 SET PSDEND=$GET(^TMP("PSDPAT1",$JOB,PSDRUG,PSDA))
End DoDot:2
End DoDot:1
+15 KILL PSDATA,PSDQTY,PSDTRQT,PSDNR1,PSDNR2,PSD0,PSD3,PSD7,PSDTR
+16 QUIT
CHKNOD7 ; COLLECTS TRANSFER DATA
+1 SET PSD7=$GET(^PSD(58.81,+PSDTR,7))
if $GET(PSD7)=""
QUIT
+2 SET PSDSTAT=$PIECE($GET(^PSD(58.81,+PSDTR,0)),U,11)
+3 SET PSDTFDT=+$PIECE(PSD7,U)
SET PSDTTON=+$PIECE(PSD7,U,3)
SET PSDT2N=$PIECE($GET(^PSD(58.8,PSDTTON,0)),U)
SET PSDTTDT=+$PIECE(PSD7,U,4)
SET PSDTPRV=+$PIECE(PSD7,U,6)
SET PSDTRQT=+$PIECE(PSD7,U,7)
+4 SET PSDTFN=$SELECT($PIECE(PSD7,U,2):$PIECE(PSD7,U,2),1:$PIECE(PSD0,U,7))
+5 if PSDTFN'=$PIECE(PSD0,U,7)
SET PSDTFN(1)=$PIECE(PSD0,U,7)
SET PSDTFN=$SELECT($PIECE($GET(^VA(200,+PSDTFN,0)),U)]"":$PIECE(^(0),U),1:"UNKNOWN")
+6 SET PSDTTNR=$PIECE($GET(PSD7),U,5)
if PSDTTNR
SET PSDTTNR=$SELECT($PIECE($GET(^VA(200,+PSDTTNR,0)),U)]"":$PIECE(^(0),U),1:"")
+7 QUIT
NODE7 ; SETS TRANSFERS BETWEEN NAOU'S
+1 IF $PIECE(PSD3,U,1)'=""
DO CHKRET
if PSD<PSDSD
QUIT
+2 IF $PIECE(PSD3,U,4)'=""
DO CHKDEST
if PSD<PSDSD
QUIT
+3 SET (PSDTFDT,PSDTFN,PSDTTDT,PSDTTNR,PSDTPRV,PSDTRQT,PSDSTAT)=""
+4 SET PSDTTON=+$PIECE(^PSD(58.81,$PIECE(PSD7,U,6),0),U,18)
SET PSDT2N=$PIECE($GET(^PSD(58.8,PSDTTON,0)),U)
SET PSDTRQT=+PSDQTY
+5 IF PSD<PSDED
IF PSD>PSDSD
SET PSDEND=0
+6 IF '$GET(PSDEND)
Begin DoDot:1
+7 SET PSDTFN=+$PIECE(^PSD(58.81,$PIECE(PSD7,U,6),7),U,2)
if PSDTFN
SET PSDTFN=$SELECT($PIECE($GET(^VA(200,+PSDTFN,0)),U)]"":$PIECE(^(0),U),1:"")
+8 SET PSDTRQT=$PIECE(^PSD(58.81,$PIECE(PSD7,U,6),7),U,7)
+9 KILL PSDATA
SET PSDATA=PSDQTY_U_PSDNR1_U_PSDNR2_U_PSDTYP_U_PSDWQT_U_$PIECE(PSD0,U,16)_"^^"_$GET(PSDNR1(1))_U_PSDRQT_U_PSDRRE
+10 SET PSDATA=PSDATA_U_PSDDRG1_U_PSDSOQT_"^^^^^^^"_PSDT2N_U_U_PSDTFN_"^^"_PSDTRQT_U
SET PSDCNT=PSDCNT+1
+11 if PSD<PSDSD
QUIT
+12 DO PSDPAT
DO PSDPATL
+13 SET PSDEND=$GET(^TMP("PSDPAT1",$JOB,PSDRUG,PSDA))
End DoDot:1
+14 IF $GET(PSDEND)
DO PSDPAT
DO PSDPATL
+15 IF $PIECE(PSD7,U,1)
SET PSDTR=PSDA
Begin DoDot:1
+16 DO CHKNOD7
+17 IF PSD<PSDED
IF PSD>PSDSD
SET PSDEND=0
+18 IF '$GET(PSDEND)
Begin DoDot:2
+19 KILL PSDATA
+20 SET $PIECE(PSDATA,U,4)=PSDTYP
SET $PIECE(PSDATA,U,17)=PSDTFDT
SET PSDATA=PSDATA_U_PSDTFN_U_PSDT2N_U_PSDTTDT_U_PSDTTNR_U_PSDTPRV_U_PSDTRQT_U_PSDSTAT
+21 SET PSDCNT=PSDCNT+1
SET PSDQTY=PSDTRQT*-1
DO PSDPAT
DO PSDPATL
End DoDot:2
+22 SET PSDEND=$GET(^TMP("PSDPAT1",$JOB,PSDRUG,PSDA))
End DoDot:1
+23 IF $GET(PSDEND)
SET PSDATA=1
DO PSDPATL
+24 QUIT
CHKRET ; SETS RETURNED ITEM INFORMATION
+1 NEW PSD,PSDNR1,PSDNR2,PSDQTY
SET PSD=$PIECE(^PSD(58.81,PSDA,0),U,19)
SET (PSDQTY,PSDWQT,PSDSOQT,PSDDQT,PSDDRE)=0
+2 SET PSDNR1=+$PIECE(^PSD(58.81,PSDA,1),U,10)
SET PSDNR1=$SELECT($PIECE($GET(^VA(200,+PSDNR1,0)),U)]"":$PIECE(^(0),U),1:"UNKNOWN")
+3 SET PSDNR2=+$PIECE(^PSD(58.81,PSDA,1),U,14)
if PSDNR2
SET PSDNR2=$SELECT($PIECE($GET(^VA(200,+PSDNR2,0)),U)]"":$PIECE(^(0),U),1:"")
+4 SET PSDRET=+$PIECE(PSD3,U)
SET PSDRQT=+$PIECE(PSD3,U,2)
SET PSDRRE=$PIECE(PSD3,U,3)
SET PSDDQT=+$PIECE(PSD3,U,5)
SET PSDDRE=$PIECE(PSD3,U,6)
SET PSDDT=+$PIECE(PSD3,U,4)
+5 KILL PSDATA
+6 SET PSDQTY=PSDRQT*-1
+7 IF PSD>PSDED
NEW PSDEND
SET PSDEND=1
+8 IF '$GET(PSDEND)
Begin DoDot:1
+9 IF PSD<PSDED
Begin DoDot:2
+10 SET PSDATA="0^"_PSDNR1_U_PSDNR2_"^99^0^"_$PIECE(PSD0,U,16)_"^0^^"_PSDRQT_U_PSDRRE_U_PSDDRG1_"^0^0^0^"_PSDRET
+11 SET PSDCNT=PSDCNT+1
+12 DO PSDPAT
DO PSDPATL
+13 SET PSDRQT=0
SET (PSDRRE,PSDRET)=""
End DoDot:2
End DoDot:1
+14 IF $GET(PSDEND)
Begin DoDot:1
+15 if PSD<PSDSD
QUIT
+16 SET PSDATA=1
DO PSDPATL
End DoDot:1
+17 SET PSDRQT=0
SET PSDRRE=""
KILL PSDATA
+18 QUIT
CHKDEST ; SETS DESTROYED ITEM INFORMATION
+1 NEW PSD,PSDNR1,PSDNR2,PSDQTY
SET PSD=$PIECE(PSD3,U,4)
+2 SET PSDNR1=+$PIECE(^PSD(58.81,PSDA,1),U,10)
SET PSDNR1=$SELECT($PIECE($GET(^VA(200,+PSDNR1,0)),U)]"":$PIECE(^(0),U),1:"UNKNOWN")
+3 SET PSDNR2=+$PIECE(^PSD(58.81,PSDA,1),U,14)
if PSDNR2
SET PSDNR2=$SELECT($PIECE($GET(^VA(200,+PSDNR2,0)),U)]"":$PIECE(^(0),U),1:"")
+4 SET PSDDQT=$PIECE(PSD3,U,5)
SET PSDDRE=$PIECE(PSD3,U,6)
KILL PSDATA
+5 IF PSD>PSDED
NEW PSDEND
SET PSDEND=1
+6 IF '$GET(PSDEND)
Begin DoDot:1
+7 if PSD<PSDSD
QUIT
+8 SET PSDATA="0^"_PSDNR1_U_PSDNR2_"^4^0^"_$PIECE(PSD0,U,16)_"^0^^0^0^"_PSDDRG1_"^0^"_PSDDQT_U_PSDDRE
+9 SET PSDCNT=PSDCNT+1
DO PSDPAT
+10 SET PSDQTY=PSDDQT*-1
SET PSDATA=1
DO PSDPATL
End DoDot:1
+11 IF $GET(PSDEND)
SET PSDQTY=PSDDQT*-1
SET PSDATA=1
DO PSDPATL
+12 KILL PSDATA
+13 QUIT
PSDPAT ;sets ^TMP("PSDPAT"
+1 if '$DATA(PSDATA)
QUIT
+2 SET ^TMP("PSDPAT",$JOB,PSDRN,PSD,PSDPAT,PSDCNT)=PSDATA
+3 QUIT
PSDPATL ;sets ^TMP("PSDPATL"
+1 if '$DATA(PSDATA)
QUIT
+2 if '$DATA(^TMP("PSDPATL",$JOB,PSDRN))
SET ^TMP("PSDPATL",$JOB,PSDRN)=0
+3 SET ^TMP("PSDPATL",$JOB,PSDRN)=+^TMP("PSDPATL",$JOB,PSDRN)+($SELECT(PSDTYP=18:-PSDQTY,PSDTYP=17:-((PSDSOQT+PSDWQT)-PSDRQT),1:PSDQTY))
SET $PIECE(^(PSDRN),U,2)=+PSDRG(PSDRUG)
+4 SET $PIECE(^TMP("PSDPATL",$JOB,PSDRN),U,3)=+$PIECE(^TMP("PSDPATL",$JOB,PSDRN),U,3)+$PIECE(PSDRG(+PSDRUG),U,2)
+5 QUIT
