PSDPAT2.m

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 ---PSDPAT2   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