PSAHIS1 ;BIR/LTL,JMB-Drug Transaction History - CONT'D ;7/23/97
;;3.0;DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,69,72,80**; 10/24/97;Build 2
;Prints the Show Drug Transaction History report in pharmacy location
;then date order. It is called by PSAHIS.
;
PRINT D HEADER S PSADRG="",PSACNT=0
F S PSADRG=$O(^TMP("PSAHIS",$J,PSADRG)) Q:PSADRG=""!(PSAOUT) K PSABAL,PSATRCNT D:$Y+6>IOSL HEADER Q:PSAOUT S PSADT=0 D Q:PSAOUT
.F S PSADT=+$O(^TMP("PSAHIS",$J,PSADRG,PSADT)) Q:'PSADT!(PSAOUT) D Q:PSAOUT
..S PSATR=0 F S PSATR=+$O(^TMP("PSAHIS",$J,PSADRG,PSADT,PSATR)) Q:'PSATR!(PSAOUT) D:$Y+6>IOSL HEADER Q:PSAOUT D TRANS
.Q:PSAOUT D:$Y+6>IOSL HEADER Q:PSAOUT D TOTALS
I 'PSACNT W !!,"No transactions were found for the pharmacy location."
Q:PSAOUT
;
DONE ;Holds screen or ejects paper if sent to printer
I $E(IOST,1,2)="C-" D
.S PSAS=21-$Y F PSASS=1:1:PSAS W !
.S DIR(0)="EA",DIR("A")="End of pharmacy location's display! Enter RETURN to continue or '^' to exit:" D ^DIR K DIR S:$G(DIRUT) PSAOUT=1
I $E(IOST)'="C" W !!!,"REPORT RUN: ",PSARUN W @IOF
Q
;
TRANS S PSATR0=$G(^PSD(58.81,PSATR,0)),PSACNT=1,PSATRCNT=$G(PSATRCNT)+1
;If it is first transaction for drug, print drug name & beg balance.
;Beg balance = 1st transaction + (receipts(+), adjs(+/-), &
;dispensing(-) made prior to beg date & fell within rpt date range)
I PSATRCNT=1 D
.W !,?37,"|",?48,"|",?54,"|",?60,"|",?71,"|" D WRAPDRUG
.S Z=$G(^PSD(58.81,+^TMP("PSA",$J,PSADRG),0))
.S PSABAL=$P(Z,"^",10)+$G(PSABAD(PSADRG)) W ?72,$J(PSABAL,7)
;
I $P(^PSD(58.81,PSATR,0),"^",2)=14 S PSATR4=$G(^PSD(58.81,PSATR,4))
;Print transaction date & +/- qty from balance
W !,$E(PSADT,4,5)_"-"_$E(PSADT,6,7)_"-"_$E(PSADT,2,3),?10,$S($P(PSATR0,"^",2)=14:$E($P($G(^VA(200,+$P(PSATR4,"^",2),0)),"^"),1,28),1:$E($P($G(^VA(200,+$P(PSATR0,"^",7),0)),"^"),1,28))
I $P(PSATR0,"^",2)'=24,$P(PSATR0,"^",2)'=9 S PSABAL=$S(",1,10,11,19,"[(","_$P(PSATR0,"^",2)_","):PSABAL+$P(PSATR0,"^",6),1:PSABAL-$P(PSATR0,"^",6)) ;;<<3*72-RJS>>
I $P(PSATR0,"^",2)=24!($P(PSATR0,"^",2)=9) S PSABAL=PSABAL+$P(PSATR0,"^",6)
I $P(PSATR0,"^",2)=14 S PSABAL=PSABAL+$P(PSATR4,"^",4)
;Receipts
I $P(PSATR0,"^",2)=1 S PSAWRT=0 W ?37,"|",?41,$J($P(PSATR0,"^",6),6),?48,"|",?54,"|",?60,"|",?71,"|",?72,$J(PSABAL,7),! S PSARECT=$G(PSARECT)+$P(PSATR0,"^",6) D Q
.I $P($G(^PRC(442,+$P(PSATR0,"^",9),0)),"^") W ?11,"PO# ",$P($G(^(0)),"^"),?37,"|",?48,"|",?54,"|",?60,"|",?71,"|" S PSALN=$G(PSALN)+1 S PSAWRT=1
.I $P($G(^PRCS(410,+$P(PSATR0,"^",8),0)),"^") W:PSAWRT ! W ?11,"TR# ",$P($G(^(0)),"^"),?37,"|",?48,"|",?54,"|",?60,"|",?71,"|" S PSALN=$G(PSALN)+1,PSAWRT=1
.I $P($G(^PSD(58.81,PSATR,8)),"^",2)'="" W:PSAWRT ! W ?11,"ORD# ",$P($G(^(8)),"^",2),?37,"|",?48,"|",?54,"|",?60,"|",?71,"|" S PSALN=$G(PSALN)+1,PSAWRT=1
.I $P($G(^PSD(58.81,PSATR,8)),"^")'="" W:PSAWRT ! W ?11,"INV# ",$P($G(^(8)),"^"),?37,"|",?48,"|",?54,"|",?60,"|",?71,"|" S PSALN=$G(PSALN)+1,PSAWRT=1
.W:$G(PSAW) !?37,"|",?48,"|",?54,"|",?60,"|",?71,"|" K PSAW
;Adjusted or transferred
I $P(PSATR0,"^",2)=9!($P(PSATR0,"^",2)=11)!($P(PSATR0,"^",2)=24) D Q
.W ?37,"|",?48,"|",?54,"|",?60,"|",?64,$J($P(PSATR0,"^",6),6),?71,"|",?72,$J(PSABAL,7)
.I +$P(PSATR0,"^",19) S PSADJDT=$P(PSATR0,"^",19) W !?11,"DATE ENTERED: "_$E(PSADJDT,4,5)_"-"_$E(PSADJDT,6,7)_"-"_$E(PSADJDT,2,3),?37,"|",?48,"|",?54,"|",?60,"|",?71,"|"
.I $P(PSATR0,"^",2)=9!($P(PSATR0,"^",2)=11),$P(PSATR0,"^",16)'="" D REASON
.D:$P(PSATR0,"^",2)=24 TRANSFER S PSADJT=$G(PSADJT)+$P(PSATR0,"^",6)
;Dispensed by IP (2 means Unit Dose or Ward Stock 15 means IV)
I $P(PSATR0,"^",2)=2!($P(PSATR0,"^",2)=15) W ?10,"NIGHTLY BACKGROUND JOB",?37,"|",?48,"|",?49,$J($P(PSATR0,"^",6),5),?54,"|",?60,"|",?71,"|",?72,$J(PSABAL,7) S PSAIPT=$G(PSAIPT)+$P(PSATR0,"^",6) Q
;Dispensed by OP
I $P(PSATR0,"^",2)=6 W ?10,"NIGHTLY BACKGROUND JOB",?37,"|",?48,"|",?54,"|",?55,$J($P(PSATR0,"^",6),5),?60,"|",?71,"|",?72,$J(PSABAL,7) S PSAOPT=$G(PSAOPT)+$P(PSATR0,"^",6)
;Return Drug Credit
I $P(PSATR0,"^",2)=10 W ?37,"|",?48,"|",?54,"|",?60,"|",?62,$J($P(PSATR0,"^",6),8),?71,"|",?72,$J($P(PSATR0,"^",10),7) S PSADJT=$G(PSADJT)+$P(PSATR0,"^",6) D REASON
;Edit Verified Invoice
I $P(PSATR0,"^",2)=14 S PSATR8=$G(^PSD(58.81,PSATR,8)) D
.W ?37,"|",?48,"|",?54,"|",?60,"|",?64,$J($P(PSATR4,"^",4),6),?71,"|",?72,$J(PSABAL,7) S PSADJT=$G(PSADJT)+$P(PSATR4,"^",4)
.W !,?11,$P($G(PSATR4),"^",6),?37,"|",?48,"|",?54,"|",?60,"|",?71,"|" S PSALN=$G(PSALN)+1,PSAWRT=1
.W !,?11,"ORD# ",$P($G(PSATR8),"^",2),?37,"|",?48,"|",?54,"|",?60,"|",?71,"|" S PSALN=$G(PSALN)+1,PSAWRT=1
.W !,?11,"INV# ",$P($G(PSATR8),"^"),?37,"|",?48,"|",?54,"|",?60,"|",?71,"|" S PSALN=$G(PSALN)+1,PSAWRT=1
.W:$G(PSAW) !?37,"|",?48,"|",?54,"|",?60,"|",?71,"|" K PSAW
Q
;
S PSAPG=PSAPG+1 I PSAPG=1,$E(IOST,1,2)="C-" W @IOF
I $E(IOST,1,2)="C-",PSAPG>1 D Q:PSAOUT
.S PSAS=21-$Y F PSASS=1:1:PSAS W !
.S DIR(0)="E" D ^DIR K DIR W:'$G(DIRUT) @IOF S:$G(DIRUT) PSAOUT=1
I $$S^%ZTLOAD W !!,"Task #",$G(ZTSK),", ",$G(ZTDESC)," was stopped by ",$P($G(^VA(200,+$G(DUZ),0)),"^"),"." S PSAOUT=1 Q
I PSAPG>1,$E(IOST)'="C" W @IOF
W !?22,"D R U G A C C O U N T A B I L I T Y",?71,"Page ",$J(PSAPG,2)
W !?((42-$L(PSABDTR)-$L(PSARPDT))/2),"HISTORY OF DRUG TRANSACTIONS FROM ",PSABDTR," TO ",PSARPDT
W !?((80-$L(PSALOCN))/2),PSALOCN
W !!?37,"|",?48,"| DISPENSED |",?71,"|"
W !,"DATE",?10,"INITIATOR",?37,"| RECEIVED | IP | OP | ADJUSTED | BALANCE"
W !,PSADLN
I $G(PSADRG)'=""&($G(PSATRCNT)) D WRAPDRUG W ?72,$J(PSABAL,7)
Q
;
ALL ;Creates drug array with all drugs in location
S PSA50=0 F S PSA50=+$O(^PSD(58.8,PSALOC,1,PSA50)) Q:'PSA50 S:$P($G(^PSDRUG(PSA50,0)),"^")'="" ^TMP("PSADRG",$J,PSALOC,$P($G(^PSDRUG(PSA50,0)),"^"),PSA50)="",PSACNT=PSACNT+1
Q
;
WRAPDRUG ;Prints drug name w/o spliting words
I $L(PSADRG)<36 W !,"* ",PSADRG,?37,"|",?48,"|",?54,"|",?60,"|",?71,"|" Q
S PSAPC1="" F PSAPCS=1:1 S PSAPC=$P(PSADRG," ",PSAPCS) Q:PSAPC="" D
.I $L(PSAPC1)+$L(PSAPC)+1<36 S PSAPC1=PSAPC1_PSAPC_" " Q
.I $L(PSAPC1)+$L(PSAPC)+1>35 W !,"* "_PSAPC1,?37,"|",?48,"|",?54,"|",?60,"|",?71,"|" S PSAPC1=PSAPC_" "
W:$L(PSAPC1) !?4,PSAPC1,?37,"|",?48,"|",?54,"|",?60,"|",?71,"|"
Q
;
REASON ;Prints transaction reason w/o spliting words
S PSAREA=$P(PSATR0,"^",16)
I $L(PSAREA)<27 W !?11,PSAREA,?37,"|",?48,"|",?54,"|",?60,"|",?71,"|" Q
S PSAPC1="" F PSAPCS=1:1 S PSAPC=$P(PSAREA," ",PSAPCS) Q:PSAPC="" D
.I $L(PSAPC1)+$L(PSAPC)+1<27 S PSAPC1=PSAPC1_PSAPC_" " Q
.I $L(PSAPC1)+$L(PSAPC)+1>26 W !?11,PSAPC1,?37,"|",?48,"|",?54,"|",?60,"|",?71,"|" S PSAPC1=PSAPC_" "
W:$L(PSAPC1) !?11,PSAPC1,?37,"|",?48,"|",?54,"|",?60,"|",?71,"|"
Q
;
TRANSFER ;Prints transfer pharm loc that rec'd or sent drugs
S PSATRANL=$P($G(^PSD(58.81,+$P(PSATR0,"^",17),0)),"^",3),PSAHOLD=PSALOC,PSAHOLDN=PSALOCN,PSALOC=PSATRANL
I PSALOC="" S PSAREA="TRANSFER DATA MISSING" S PSALOC=PSAHOLD,PSALOCN=PSAHOLDN Q
D SITES^PSAUTL1 S PSALOCN=$P(^PSD(58.8,PSALOC,0),"^")_PSACOMB
S PSAREA="TRANSFER "_$S($P(PSATR0,"^",6)<0:"TO ",1:"FROM ") D TRAN
S PSALOC=PSAHOLD,PSALOCN=PSAHOLDN
S PSAPC1="" F PSAPCS=1:1 S PSAPC=$P(PSAREA," ",PSAPCS) Q:PSAPC="" D
.I $L(PSAPC1)+$L(PSAPC)+1<27 S PSAPC1=PSAPC1_PSAPC_" " Q
.I $L(PSAPC1)+$L(PSAPC)+1>26 W !?11,PSAPC1,?37,"|",?48,"|",?54,"|",?60,"|",?71,"|" S PSAPC1=PSAPC_" "
W:$L(PSAPC1) !?11,PSAPC1,?37,"|",?48,"|",?54,"|",?60,"|",?71,"|"
Q
;
TRAN ;Prints transferred location w/o spliting words
I $E(PSALOCN)="I" S PSAREA=PSAREA_"INPATIENT:"_$P($P(PSALOCN,":",2),"(IP)")
I $E(PSALOCN)="O" S PSAREA=PSAREA_"OUTPATIENT:"_$P($P(PSALOCN,":",2),"(OP)")
I $E(PSALOCN)="C" S PSAREA=PSAREA_"COMBINED:"_$P($P(PSALOCN,":",2),"(IP)")_"(IP)"_$P($P(PSALOCN,":",2),"(IP)",2)
W !?11,$P(PSAREA,":")_":",?37,"|",?48,"|",?54,"|",?60,"|",?71,"|"
S PSAREA=$P(PSAREA,": ",2)
Q
;
TOTALS ;Prints totals
W !?37,"|----------|-----|-----|----------|--------"
W !?25,"DRUG TOTALS",?37,"|",?41,$J($G(PSARECT),6),?48,"|",$J($G(PSAIPT),5),?54,"|",$J($G(PSAOPT),5),?60,"|",?64,$J($G(PSADJT),6),?71,"|",!,PSADLN
K PSADJT,PSAIPT,PSAOPT,PSARECT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSAHIS1 8134 printed Sep 23, 2025@19:25:25 Page 2
PSAHIS1 ;BIR/LTL,JMB-Drug Transaction History - CONT'D ;7/23/97
+1 ;;3.0;DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,69,72,80**; 10/24/97;Build 2
+2 ;Prints the Show Drug Transaction History report in pharmacy location
+3 ;then date order. It is called by PSAHIS.
+4 ;
PRINT DO HEADER
SET PSADRG=""
SET PSACNT=0
+1 FOR
SET PSADRG=$ORDER(^TMP("PSAHIS",$JOB,PSADRG))
if PSADRG=""!(PSAOUT)
QUIT
KILL PSABAL,PSATRCNT
if $Y+6>IOSL
DO HEADER
if PSAOUT
QUIT
SET PSADT=0
Begin DoDot:1
+2 FOR
SET PSADT=+$ORDER(^TMP("PSAHIS",$JOB,PSADRG,PSADT))
if 'PSADT!(PSAOUT)
QUIT
Begin DoDot:2
+3 SET PSATR=0
FOR
SET PSATR=+$ORDER(^TMP("PSAHIS",$JOB,PSADRG,PSADT,PSATR))
if 'PSATR!(PSAOUT)
QUIT
if $Y+6>IOSL
DO HEADER
if PSAOUT
QUIT
DO TRANS
End DoDot:2
if PSAOUT
QUIT
+4 if PSAOUT
QUIT
if $Y+6>IOSL
DO HEADER
if PSAOUT
QUIT
DO TOTALS
End DoDot:1
if PSAOUT
QUIT
+5 IF 'PSACNT
WRITE !!,"No transactions were found for the pharmacy location."
+6 if PSAOUT
QUIT
+7 ;
DONE ;Holds screen or ejects paper if sent to printer
+1 IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:1
+2 SET PSAS=21-$Y
FOR PSASS=1:1:PSAS
WRITE !
+3 SET DIR(0)="EA"
SET DIR("A")="End of pharmacy location's display! Enter RETURN to continue or '^' to exit:"
DO ^DIR
KILL DIR
if $GET(DIRUT)
SET PSAOUT=1
End DoDot:1
+4 IF $EXTRACT(IOST)'="C"
WRITE !!!,"REPORT RUN: ",PSARUN
WRITE @IOF
+5 QUIT
+6 ;
TRANS SET PSATR0=$GET(^PSD(58.81,PSATR,0))
SET PSACNT=1
SET PSATRCNT=$GET(PSATRCNT)+1
+1 ;If it is first transaction for drug, print drug name & beg balance.
+2 ;Beg balance = 1st transaction + (receipts(+), adjs(+/-), &
+3 ;dispensing(-) made prior to beg date & fell within rpt date range)
+4 IF PSATRCNT=1
Begin DoDot:1
+5 WRITE !,?37,"|",?48,"|",?54,"|",?60,"|",?71,"|"
DO WRAPDRUG
+6 SET Z=$GET(^PSD(58.81,+^TMP("PSA",$JOB,PSADRG),0))
+7 SET PSABAL=$PIECE(Z,"^",10)+$GET(PSABAD(PSADRG))
WRITE ?72,$JUSTIFY(PSABAL,7)
End DoDot:1
+8 ;
+9 IF $PIECE(^PSD(58.81,PSATR,0),"^",2)=14
SET PSATR4=$GET(^PSD(58.81,PSATR,4))
+10 ;Print transaction date & +/- qty from balance
+11 WRITE !,$EXTRACT(PSADT,4,5)_"-"_$EXTRACT(PSADT,6,7)_"-"_$EXTRACT(PSADT,2,3),?10,$SELECT($PIECE(PSATR0,"^",2)=14:$EXTRACT($PIECE($GET(^VA(200,+$PIECE(PSATR4,"^",2),0)),"^"),1,28),1:$EXTRACT($PIECE($GET(^VA(200,+$PIECE(PSATR0,"^",7),0)),"^"),1,28
))
+12 ;;<<3*72-RJS>>
IF $PIECE(PSATR0,"^",2)'=24
IF $PIECE(PSATR0,"^",2)'=9
SET PSABAL=$SELECT(",1,10,11,19,"[(","_$PIECE(PSATR0,"^",2)_","):PSABAL+$PIECE(PSATR0,"^",6),1:PSABAL-$PIECE(PSATR0,"^",6))
+13 IF $PIECE(PSATR0,"^",2)=24!($PIECE(PSATR0,"^",2)=9)
SET PSABAL=PSABAL+$PIECE(PSATR0,"^",6)
+14 IF $PIECE(PSATR0,"^",2)=14
SET PSABAL=PSABAL+$PIECE(PSATR4,"^",4)
+15 ;Receipts
+16 IF $PIECE(PSATR0,"^",2)=1
SET PSAWRT=0
WRITE ?37,"|",?41,$JUSTIFY($PIECE(PSATR0,"^",6),6),?48,"|",?54,"|",?60,"|",?71,"|",?72,$JUSTIFY(PSABAL,7),!
SET PSARECT=$GET(PSARECT)+$PIECE(PSATR0,"^",6)
Begin DoDot:1
+17 IF $PIECE($GET(^PRC(442,+$PIECE(PSATR0,"^",9),0)),"^")
WRITE ?11,"PO# ",$PIECE($GET(^(0)),"^"),?37,"|",?48,"|",?54,"|",?60,"|",?71,"|"
SET PSALN=$GET(PSALN)+1
SET PSAWRT=1
+18 IF $PIECE($GET(^PRCS(410,+$PIECE(PSATR0,"^",8),0)),"^")
if PSAWRT
WRITE !
WRITE ?11,"TR# ",$PIECE($GET(^(0)),"^"),?37,"|",?48,"|",?54,"|",?60,"|",?71,"|"
SET PSALN=$GET(PSALN)+1
SET PSAWRT=1
+19 IF $PIECE($GET(^PSD(58.81,PSATR,8)),"^",2)'=""
if PSAWRT
WRITE !
WRITE ?11,"ORD# ",$PIECE($GET(^(8)),"^",2),?37,"|",?48,"|",?54,"|",?60,"|",?71,"|"
SET PSALN=$GET(PSALN)+1
SET PSAWRT=1
+20 IF $PIECE($GET(^PSD(58.81,PSATR,8)),"^")'=""
if PSAWRT
WRITE !
WRITE ?11,"INV# ",$PIECE($GET(^(8)),"^"),?37,"|",?48,"|",?54,"|",?60,"|",?71,"|"
SET PSALN=$GET(PSALN)+1
SET PSAWRT=1
+21 if $GET(PSAW)
WRITE !?37,"|",?48,"|",?54,"|",?60,"|",?71,"|"
KILL PSAW
End DoDot:1
QUIT
+22 ;Adjusted or transferred
+23 IF $PIECE(PSATR0,"^",2)=9!($PIECE(PSATR0,"^",2)=11)!($PIECE(PSATR0,"^",2)=24)
Begin DoDot:1
+24 WRITE ?37,"|",?48,"|",?54,"|",?60,"|",?64,$JUSTIFY($PIECE(PSATR0,"^",6),6),?71,"|",?72,$JUSTIFY(PSABAL,7)
+25 IF +$PIECE(PSATR0,"^",19)
SET PSADJDT=$PIECE(PSATR0,"^",19)
WRITE !?11,"DATE ENTERED: "_$EXTRACT(PSADJDT,4,5)_"-"_$EXTRACT(PSADJDT,6,7)_"-"_$EXTRACT(PSADJDT,2,3),?37,"|",?48,"|",?54,"|",?60,"|",?71,"|"
+26 IF $PIECE(PSATR0,"^",2)=9!($PIECE(PSATR0,"^",2)=11)
IF $PIECE(PSATR0,"^",16)'=""
DO REASON
+27 if $PIECE(PSATR0,"^",2)=24
DO TRANSFER
SET PSADJT=$GET(PSADJT)+$PIECE(PSATR0,"^",6)
End DoDot:1
QUIT
+28 ;Dispensed by IP (2 means Unit Dose or Ward Stock 15 means IV)
+29 IF $PIECE(PSATR0,"^",2)=2!($PIECE(PSATR0,"^",2)=15)
WRITE ?10,"NIGHTLY BACKGROUND JOB",?37,"|",?48,"|",?49,$JUSTIFY($PIECE(PSATR0,"^",6),5),?54,"|",?60,"|",?71,"|",?72,$JUSTIFY(PSABAL,7)
SET PSAIPT=$GET(PSAIPT)+$PIECE(PSATR0,"^",6)
QUIT
+30 ;Dispensed by OP
+31 IF $PIECE(PSATR0,"^",2)=6
WRITE ?10,"NIGHTLY BACKGROUND JOB",?37,"|",?48,"|",?54,"|",?55,$JUSTIFY($PIECE(PSATR0,"^",6),5),?60,"|",?71,"|",?72,$JUSTIFY(PSABAL,7)
SET PSAOPT=$GET(PSAOPT)+$PIECE(PSATR0,"^",6)
+32 ;Return Drug Credit
+33 IF $PIECE(PSATR0,"^",2)=10
WRITE ?37,"|",?48,"|",?54,"|",?60,"|",?62,$JUSTIFY($PIECE(PSATR0,"^",6),8),?71,"|",?72,$JUSTIFY($PIECE(PSATR0,"^",10),7)
SET PSADJT=$GET(PSADJT)+$PIECE(PSATR0,"^",6)
DO REASON
+34 ;Edit Verified Invoice
+35 IF $PIECE(PSATR0,"^",2)=14
SET PSATR8=$GET(^PSD(58.81,PSATR,8))
Begin DoDot:1
+36 WRITE ?37,"|",?48,"|",?54,"|",?60,"|",?64,$JUSTIFY($PIECE(PSATR4,"^",4),6),?71,"|",?72,$JUSTIFY(PSABAL,7)
SET PSADJT=$GET(PSADJT)+$PIECE(PSATR4,"^",4)
+37 WRITE !,?11,$PIECE($GET(PSATR4),"^",6),?37,"|",?48,"|",?54,"|",?60,"|",?71,"|"
SET PSALN=$GET(PSALN)+1
SET PSAWRT=1
+38 WRITE !,?11,"ORD# ",$PIECE($GET(PSATR8),"^",2),?37,"|",?48,"|",?54,"|",?60,"|",?71,"|"
SET PSALN=$GET(PSALN)+1
SET PSAWRT=1
+39 WRITE !,?11,"INV# ",$PIECE($GET(PSATR8),"^"),?37,"|",?48,"|",?54,"|",?60,"|",?71,"|"
SET PSALN=$GET(PSALN)+1
SET PSAWRT=1
+40 if $GET(PSAW)
WRITE !?37,"|",?48,"|",?54,"|",?60,"|",?71,"|"
KILL PSAW
End DoDot:1
+41 QUIT
+42 ;
+1 SET PSAPG=PSAPG+1
IF PSAPG=1
IF $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+2 IF $EXTRACT(IOST,1,2)="C-"
IF PSAPG>1
Begin DoDot:1
+3 SET PSAS=21-$Y
FOR PSASS=1:1:PSAS
WRITE !
+4 SET DIR(0)="E"
DO ^DIR
KILL DIR
if '$GET(DIRUT)
WRITE @IOF
if $GET(DIRUT)
SET PSAOUT=1
End DoDot:1
if PSAOUT
QUIT
+5 IF $$S^%ZTLOAD
WRITE !!,"Task #",$GET(ZTSK),", ",$GET(ZTDESC)," was stopped by ",$PIECE($GET(^VA(200,+$GET(DUZ),0)),"^"),"."
SET PSAOUT=1
QUIT
+6 IF PSAPG>1
IF $EXTRACT(IOST)'="C"
WRITE @IOF
+7 WRITE !?22,"D R U G A C C O U N T A B I L I T Y",?71,"Page ",$JUSTIFY(PSAPG,2)
+8 WRITE !?((42-$LENGTH(PSABDTR)-$LENGTH(PSARPDT))/2),"HISTORY OF DRUG TRANSACTIONS FROM ",PSABDTR," TO ",PSARPDT
+9 WRITE !?((80-$LENGTH(PSALOCN))/2),PSALOCN
+10 WRITE !!?37,"|",?48,"| DISPENSED |",?71,"|"
+11 WRITE !,"DATE",?10,"INITIATOR",?37,"| RECEIVED | IP | OP | ADJUSTED | BALANCE"
+12 WRITE !,PSADLN
+13 IF $GET(PSADRG)'=""&($GET(PSATRCNT))
DO WRAPDRUG
WRITE ?72,$JUSTIFY(PSABAL,7)
+14 QUIT
+15 ;
ALL ;Creates drug array with all drugs in location
+1 SET PSA50=0
FOR
SET PSA50=+$ORDER(^PSD(58.8,PSALOC,1,PSA50))
if 'PSA50
QUIT
if $PIECE($GET(^PSDRUG(PSA50,0)),"^")'=""
SET ^TMP("PSADRG",$JOB,PSALOC,$PIECE($GET(^PSDRUG(PSA50,0)),"^"),PSA50)=""
SET PSACNT=PSACNT+1
+2 QUIT
+3 ;
WRAPDRUG ;Prints drug name w/o spliting words
+1 IF $LENGTH(PSADRG)<36
WRITE !,"* ",PSADRG,?37,"|",?48,"|",?54,"|",?60,"|",?71,"|"
QUIT
+2 SET PSAPC1=""
FOR PSAPCS=1:1
SET PSAPC=$PIECE(PSADRG," ",PSAPCS)
if PSAPC=""
QUIT
Begin DoDot:1
+3 IF $LENGTH(PSAPC1)+$LENGTH(PSAPC)+1<36
SET PSAPC1=PSAPC1_PSAPC_" "
QUIT
+4 IF $LENGTH(PSAPC1)+$LENGTH(PSAPC)+1>35
WRITE !,"* "_PSAPC1,?37,"|",?48,"|",?54,"|",?60,"|",?71,"|"
SET PSAPC1=PSAPC_" "
End DoDot:1
+5 if $LENGTH(PSAPC1)
WRITE !?4,PSAPC1,?37,"|",?48,"|",?54,"|",?60,"|",?71,"|"
+6 QUIT
+7 ;
REASON ;Prints transaction reason w/o spliting words
+1 SET PSAREA=$PIECE(PSATR0,"^",16)
+2 IF $LENGTH(PSAREA)<27
WRITE !?11,PSAREA,?37,"|",?48,"|",?54,"|",?60,"|",?71,"|"
QUIT
+3 SET PSAPC1=""
FOR PSAPCS=1:1
SET PSAPC=$PIECE(PSAREA," ",PSAPCS)
if PSAPC=""
QUIT
Begin DoDot:1
+4 IF $LENGTH(PSAPC1)+$LENGTH(PSAPC)+1<27
SET PSAPC1=PSAPC1_PSAPC_" "
QUIT
+5 IF $LENGTH(PSAPC1)+$LENGTH(PSAPC)+1>26
WRITE !?11,PSAPC1,?37,"|",?48,"|",?54,"|",?60,"|",?71,"|"
SET PSAPC1=PSAPC_" "
End DoDot:1
+6 if $LENGTH(PSAPC1)
WRITE !?11,PSAPC1,?37,"|",?48,"|",?54,"|",?60,"|",?71,"|"
+7 QUIT
+8 ;
TRANSFER ;Prints transfer pharm loc that rec'd or sent drugs
+1 SET PSATRANL=$PIECE($GET(^PSD(58.81,+$PIECE(PSATR0,"^",17),0)),"^",3)
SET PSAHOLD=PSALOC
SET PSAHOLDN=PSALOCN
SET PSALOC=PSATRANL
+2 IF PSALOC=""
SET PSAREA="TRANSFER DATA MISSING"
SET PSALOC=PSAHOLD
SET PSALOCN=PSAHOLDN
QUIT
+3 DO SITES^PSAUTL1
SET PSALOCN=$PIECE(^PSD(58.8,PSALOC,0),"^")_PSACOMB
+4 SET PSAREA="TRANSFER "_$SELECT($PIECE(PSATR0,"^",6)<0:"TO ",1:"FROM ")
DO TRAN
+5 SET PSALOC=PSAHOLD
SET PSALOCN=PSAHOLDN
+6 SET PSAPC1=""
FOR PSAPCS=1:1
SET PSAPC=$PIECE(PSAREA," ",PSAPCS)
if PSAPC=""
QUIT
Begin DoDot:1
+7 IF $LENGTH(PSAPC1)+$LENGTH(PSAPC)+1<27
SET PSAPC1=PSAPC1_PSAPC_" "
QUIT
+8 IF $LENGTH(PSAPC1)+$LENGTH(PSAPC)+1>26
WRITE !?11,PSAPC1,?37,"|",?48,"|",?54,"|",?60,"|",?71,"|"
SET PSAPC1=PSAPC_" "
End DoDot:1
+9 if $LENGTH(PSAPC1)
WRITE !?11,PSAPC1,?37,"|",?48,"|",?54,"|",?60,"|",?71,"|"
+10 QUIT
+11 ;
TRAN ;Prints transferred location w/o spliting words
+1 IF $EXTRACT(PSALOCN)="I"
SET PSAREA=PSAREA_"INPATIENT:"_$PIECE($PIECE(PSALOCN,":",2),"(IP)")
+2 IF $EXTRACT(PSALOCN)="O"
SET PSAREA=PSAREA_"OUTPATIENT:"_$PIECE($PIECE(PSALOCN,":",2),"(OP)")
+3 IF $EXTRACT(PSALOCN)="C"
SET PSAREA=PSAREA_"COMBINED:"_$PIECE($PIECE(PSALOCN,":",2),"(IP)")_"(IP)"_$PIECE($PIECE(PSALOCN,":",2),"(IP)",2)
+4 WRITE !?11,$PIECE(PSAREA,":")_":",?37,"|",?48,"|",?54,"|",?60,"|",?71,"|"
+5 SET PSAREA=$PIECE(PSAREA,": ",2)
+6 QUIT
+7 ;
TOTALS ;Prints totals
+1 WRITE !?37,"|----------|-----|-----|----------|--------"
+2 WRITE !?25,"DRUG TOTALS",?37,"|",?41,$JUSTIFY($GET(PSARECT),6),?48,"|",$JUSTIFY($GET(PSAIPT),5),?54,"|",$JUSTIFY($GET(PSAOPT),5),?60,"|",?64,$JUSTIFY($GET(PSADJT),6),?71,"|",!,PSADLN
+3 KILL PSADJT,PSAIPT,PSAOPT,PSARECT
+4 QUIT
