PSASIG ;BIR/JMB-Transfer Signature Sheet ;7/23/97
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;; 10/24/97
;This routine prints transfer signature sheets.
;
TEMP ;Entry point for printing immediately after transfer is entered. It is
;called by PSATRAN1. All transactions are placed in ^TMP("PSASIG",$J)
;while inputing the transaction. The transfer sheets are printed using
;this array.
W ! S %ZIS="Q" D ^%ZIS G:POP EXIT
I $D(IO("Q")) D G EXIT
.S ZTDESC="Drug Acct.-Print Transfer Signature Sheets",ZTRTN="TQUE^PSASIG"
.S ZTSAVE("^TMP(""PSASIG"",$J,")="" D ^%ZTLOAD
TQUE S PSAOUT=0,PSAFIRST=1,PSASLN="",$P(PSASLN,"-",80)="",PSADLN="",$P(PSADLN,"=",80)=""
D NOW^%DTC S Y=+$E(%,1,12) X ^DD("DD") S PSARPDT=Y
S PSAFROM=0 F S PSAFROM=+$O(^TMP("PSASIG",$J,PSAFROM)) Q:'PSAFROM!(PSAOUT) S PSATO=0 F S PSATO=+$O(^TMP("PSASIG",$J,PSAFROM,PSATO)) Q:'PSATO!(PSAOUT) D
.S PSAPG=0,PSALOC=PSAFROM D SITES^PSAUTL1 S PSAFROMN=$P(^PSD(58.8,PSALOC,0),"^")_PSACOMB
.S PSALOC=PSATO D SITES^PSAUTL1 S PSATON=$P(^PSD(58.8,PSALOC,0),"^")_PSACOMB
.D HDR Q:PSAOUT
.S PSADA=0 F S PSADA=$O(^TMP("PSASIG",$J,PSAFROM,PSATO,PSADA)) Q:'PSADA!(PSAOUT) D PRINT S PSAFIRST=0
EXIT I $E(IOST)'="C" W @IOF
I $E(IOST,1,2)="C-",'PSAOUT D
.S PSASS=21-$Y F PSAKK=1:1:PSASS W !
.S DIR(0)="E",DIR("A")="END OF REPORT! Press <RET> to return to the menu" D ^DIR K DIR W @IOF
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" K IO("Q")
K ^TMP("PSASIG",$J),%,%ZIS,DIR,DTOUT,PSABAL,PSABEG,PSACHK,PSACNT,PSACOMB,PSADA,PSADLN,PSADRG,PSADT,PSAEND,PSAFIRST,PSAFROM,PSAFROMN,PSAKK
K PSALOC,PSALOCA,PSALOCN,PSANODE,PSAOUT,PSAPG,PSAQTY,PSAREPRT,PSARPDT,PSASAVE,PSASEL,PSASLN,PSASS,PSATO,PSATON,PSATRAN,PSATRDT,PSAWHO,Y,ZTDESC,ZTRTN,ZTSAVE
Q
;
REPRINT ;Entry point for Transfer Signature Sheets. It prompts for the
;dispensing pharmacy location, receiving pharmacy location, beginning
;date, then ending date.
S PSAREPRT=1,(PSACNT,PSAOUT)=0,PSATRAN="F"
D ^PSAUTL3 G:PSAOUT EXIT S PSACNT=0,PSACHK=$O(PSALOC(""))
I PSACHK="",'PSALOC W !,"There are no active pharmacy locations." G EXIT
S PSAFROM=+PSALOC,PSAFROMN=PSALOCN D TO^PSATRAN
D BDATE^PSAPV
W ! S %ZIS="Q" D ^%ZIS G:POP EXIT
I $D(IO("Q")) D G EXIT
.S ZTDESC="Drug Acct.-Reprint Transfer Signature Sheets",ZTRTN="RQUE^PSASIG"
.F PSASAVE="PSABEG","PSAEND","PSAFROM","PSAFROMN","PSATO","PSATON" S:$D(PSASAVE) ZTSAVE(PSASAVE)=""
.S ZTSAVE("^TMP(""PSASIG"",$J,")="" D ^%ZTLOAD
RQUE S (PSAPG,PSAOUT)=0,PSAREPRT=1,PSASLN="",$P(PSASLN,"-",80)="",PSADLN="",$P(PSADLN,"=",80)="",PSADT=PSABEG
D NOW^%DTC S Y=+$E(%,1,12) X ^DD("DD") S PSARPDT=Y,PSAFIRST=1
D HDR S PSAFIRST=0
F S PSADT=+$O(^PSD(58.81,"AF",PSADT)) Q:'PSADT!($P(PSADT,".")>PSAEND)!(PSAOUT) S PSADA=0 F S PSADA=+$O(^PSD(58.81,"AF",PSADT,PSAFROM,24,PSADA)) Q:'PSADA!(PSAOUT) D
.S PSANODE=$G(^PSD(58.81,PSADA,0)) I $P(PSANODE,"^",6)<0,$P($G(^PSD(58.81,+$P(PSANODE,"^",17),0)),"^",3)=PSATO D PRINT
G EXIT
;
PRINT S PSANODE=$G(^PSD(58.81,PSADA,0)),PSATRDT=$E($$FMTE^XLFDT($P(PSANODE,"^",4),1),1,18),PSADRG=$P(PSANODE,"^",5)
S PSAQTY=$P(PSANODE,"^",6),PSAWHO=$P($G(^VA(200,+$P(PSANODE,"^",7),0)),"^"),PSABAL=+$P(PSANODE,"^",10)
S:PSAQTY<0 PSAQTY=-PSAQTY D:$Y+7>IOSL HDR Q:PSAOUT
W !,PSATRDT,?20,$J(PSAQTY,6),?30,$S($P($G(^PSDRUG(PSADRG,0)),"^")'="":$P($G(^PSDRUG(PSADRG,0)),"^"),1:"UNKNOWN"),?73,$S(+PSABAL:$J((PSABAL-PSAQTY),6),1:"UNKNOWN")
W !!,?2,"Dispensed by: "_$S(PSAWHO'="":PSAWHO,1:"_____________________"),?40,"Rec'd by: ____________________________"
W !,?20,"(Full Name)",?55,"(Full Name)",!,PSADLN
Q
;
HDR ;Header
I $E(IOST,1,2)="C-",'PSAFIRST D I 'Y S PSAOUT=1 Q
.S PSASS=21-$Y F PSAKK=1:1:PSASS W !
.S DIR(0)="E" D ^DIR K DIR
I $E(IOST,1,2)="C-",'PSAPG W @IOF
W:$E(IOST,1,2)'="C-"&('PSAPG)&('PSAFIRST) @IOF
W:PSAPG @IOF S PSAPG=PSAPG+1
W:$G(PSAREPRT) !,?32,"*** REPRINT ***"
W !,PSARPDT,?20,"DRUG ACCOUNTABILITY/INVENTORY INTERFACE",?72,"Page: ",PSAPG
W !?18,"DRUG TRANSFER BETWEEN PHARMACIES SIGNATURE SHEET"
W:$L(PSAFROMN)>76 !!,$P(PSAFROMN,"(IP)",1)_"(IP)",!?17,$P(PSAFROMN,"(IP)",2) W:$L(PSAFROMN)<77 !?((80-$L(PSAFROMN))/2),PSAFROMN
W !!!,"TRANSFERRED TO: " W:$L(PSATON)>63 $P(PSATON,"(IP)",1)_"(IP)",!?17,$P(PSATON,"(IP)",2) W:$L(PSATON)<74 PSATON W !,PSASLN
W !,"TRANSFER DATE",?23,"QTY",?30,"DRUG",?68,"NEW BALANCE",!,PSASLN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSASIG 4327 printed Apr 09, 2024@20:54:05 Page 2
PSASIG ;BIR/JMB-Transfer Signature Sheet ;7/23/97
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;; 10/24/97
+2 ;This routine prints transfer signature sheets.
+3 ;
TEMP ;Entry point for printing immediately after transfer is entered. It is
+1 ;called by PSATRAN1. All transactions are placed in ^TMP("PSASIG",$J)
+2 ;while inputing the transaction. The transfer sheets are printed using
+3 ;this array.
+4 WRITE !
SET %ZIS="Q"
DO ^%ZIS
if POP
GOTO EXIT
+5 IF $DATA(IO("Q"))
Begin DoDot:1
+6 SET ZTDESC="Drug Acct.-Print Transfer Signature Sheets"
SET ZTRTN="TQUE^PSASIG"
+7 SET ZTSAVE("^TMP(""PSASIG"",$J,")=""
DO ^%ZTLOAD
End DoDot:1
GOTO EXIT
TQUE SET PSAOUT=0
SET PSAFIRST=1
SET PSASLN=""
SET $PIECE(PSASLN,"-",80)=""
SET PSADLN=""
SET $PIECE(PSADLN,"=",80)=""
+1 DO NOW^%DTC
SET Y=+$EXTRACT(%,1,12)
XECUTE ^DD("DD")
SET PSARPDT=Y
+2 SET PSAFROM=0
FOR
SET PSAFROM=+$ORDER(^TMP("PSASIG",$JOB,PSAFROM))
if 'PSAFROM!(PSAOUT)
QUIT
SET PSATO=0
FOR
SET PSATO=+$ORDER(^TMP("PSASIG",$JOB,PSAFROM,PSATO))
if 'PSATO!(PSAOUT)
QUIT
Begin DoDot:1
+3 SET PSAPG=0
SET PSALOC=PSAFROM
DO SITES^PSAUTL1
SET PSAFROMN=$PIECE(^PSD(58.8,PSALOC,0),"^")_PSACOMB
+4 SET PSALOC=PSATO
DO SITES^PSAUTL1
SET PSATON=$PIECE(^PSD(58.8,PSALOC,0),"^")_PSACOMB
+5 DO HDR
if PSAOUT
QUIT
+6 SET PSADA=0
FOR
SET PSADA=$ORDER(^TMP("PSASIG",$JOB,PSAFROM,PSATO,PSADA))
if 'PSADA!(PSAOUT)
QUIT
DO PRINT
SET PSAFIRST=0
End DoDot:1
EXIT IF $EXTRACT(IOST)'="C"
WRITE @IOF
+1 IF $EXTRACT(IOST,1,2)="C-"
IF 'PSAOUT
Begin DoDot:1
+2 SET PSASS=21-$Y
FOR PSAKK=1:1:PSASS
WRITE !
+3 SET DIR(0)="E"
SET DIR("A")="END OF REPORT! Press <RET> to return to the menu"
DO ^DIR
KILL DIR
WRITE @IOF
End DoDot:1
+4 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL IO("Q")
+5 KILL ^TMP("PSASIG",$JOB),%,%ZIS,DIR,DTOUT,PSABAL,PSABEG,PSACHK,PSACNT,PSACOMB,PSADA,PSADLN,PSADRG,PSADT,PSAEND,PSAFIRST,PSAFROM,PSAFROMN,PSAKK
+6 KILL PSALOC,PSALOCA,PSALOCN,PSANODE,PSAOUT,PSAPG,PSAQTY,PSAREPRT,PSARPDT,PSASAVE,PSASEL,PSASLN,PSASS,PSATO,PSATON,PSATRAN,PSATRDT,PSAWHO,Y,ZTDESC,ZTRTN,ZTSAVE
+7 QUIT
+8 ;
REPRINT ;Entry point for Transfer Signature Sheets. It prompts for the
+1 ;dispensing pharmacy location, receiving pharmacy location, beginning
+2 ;date, then ending date.
+3 SET PSAREPRT=1
SET (PSACNT,PSAOUT)=0
SET PSATRAN="F"
+4 DO ^PSAUTL3
if PSAOUT
GOTO EXIT
SET PSACNT=0
SET PSACHK=$ORDER(PSALOC(""))
+5 IF PSACHK=""
IF 'PSALOC
WRITE !,"There are no active pharmacy locations."
GOTO EXIT
+6 SET PSAFROM=+PSALOC
SET PSAFROMN=PSALOCN
DO TO^PSATRAN
+7 DO BDATE^PSAPV
+8 WRITE !
SET %ZIS="Q"
DO ^%ZIS
if POP
GOTO EXIT
+9 IF $DATA(IO("Q"))
Begin DoDot:1
+10 SET ZTDESC="Drug Acct.-Reprint Transfer Signature Sheets"
SET ZTRTN="RQUE^PSASIG"
+11 FOR PSASAVE="PSABEG","PSAEND","PSAFROM","PSAFROMN","PSATO","PSATON"
if $DATA(PSASAVE)
SET ZTSAVE(PSASAVE)=""
+12 SET ZTSAVE("^TMP(""PSASIG"",$J,")=""
DO ^%ZTLOAD
End DoDot:1
GOTO EXIT
RQUE SET (PSAPG,PSAOUT)=0
SET PSAREPRT=1
SET PSASLN=""
SET $PIECE(PSASLN,"-",80)=""
SET PSADLN=""
SET $PIECE(PSADLN,"=",80)=""
SET PSADT=PSABEG
+1 DO NOW^%DTC
SET Y=+$EXTRACT(%,1,12)
XECUTE ^DD("DD")
SET PSARPDT=Y
SET PSAFIRST=1
+2 DO HDR
SET PSAFIRST=0
+3 FOR
SET PSADT=+$ORDER(^PSD(58.81,"AF",PSADT))
if 'PSADT!($PIECE(PSADT,".")>PSAEND)!(PSAOUT)
QUIT
SET PSADA=0
FOR
SET PSADA=+$ORDER(^PSD(58.81,"AF",PSADT,PSAFROM,24,PSADA))
if 'PSADA!(PSAOUT)
QUIT
Begin DoDot:1
+4 SET PSANODE=$GET(^PSD(58.81,PSADA,0))
IF $PIECE(PSANODE,"^",6)<0
IF $PIECE($GET(^PSD(58.81,+$PIECE(PSANODE,"^",17),0)),"^",3)=PSATO
DO PRINT
End DoDot:1
+5 GOTO EXIT
+6 ;
PRINT SET PSANODE=$GET(^PSD(58.81,PSADA,0))
SET PSATRDT=$EXTRACT($$FMTE^XLFDT($PIECE(PSANODE,"^",4),1),1,18)
SET PSADRG=$PIECE(PSANODE,"^",5)
+1 SET PSAQTY=$PIECE(PSANODE,"^",6)
SET PSAWHO=$PIECE($GET(^VA(200,+$PIECE(PSANODE,"^",7),0)),"^")
SET PSABAL=+$PIECE(PSANODE,"^",10)
+2 if PSAQTY<0
SET PSAQTY=-PSAQTY
if $Y+7>IOSL
DO HDR
if PSAOUT
QUIT
+3 WRITE !,PSATRDT,?20,$JUSTIFY(PSAQTY,6),?30,$SELECT($PIECE($GET(^PSDRUG(PSADRG,0)),"^")'="":$PIECE($GET(^PSDRUG(PSADRG,0)),"^"),1:"UNKNOWN"),?73,$SELECT(+PSABAL:$JUSTIFY((PSABAL-PSAQTY),6),1:"UNKNOWN")
+4 WRITE !!,?2,"Dispensed by: "_$SELECT(PSAWHO'="":PSAWHO,1:"_____________________"),?40,"Rec'd by: ____________________________"
+5 WRITE !,?20,"(Full Name)",?55,"(Full Name)",!,PSADLN
+6 QUIT
+7 ;
HDR ;Header
+1 IF $EXTRACT(IOST,1,2)="C-"
IF 'PSAFIRST
Begin DoDot:1
+2 SET PSASS=21-$Y
FOR PSAKK=1:1:PSASS
WRITE !
+3 SET DIR(0)="E"
DO ^DIR
KILL DIR
End DoDot:1
IF 'Y
SET PSAOUT=1
QUIT
+4 IF $EXTRACT(IOST,1,2)="C-"
IF 'PSAPG
WRITE @IOF
+5 if $EXTRACT(IOST,1,2)'="C-"&('PSAPG)&('PSAFIRST)
WRITE @IOF
+6 if PSAPG
WRITE @IOF
SET PSAPG=PSAPG+1
+7 if $GET(PSAREPRT)
WRITE !,?32,"*** REPRINT ***"
+8 WRITE !,PSARPDT,?20,"DRUG ACCOUNTABILITY/INVENTORY INTERFACE",?72,"Page: ",PSAPG
+9 WRITE !?18,"DRUG TRANSFER BETWEEN PHARMACIES SIGNATURE SHEET"
+10 if $LENGTH(PSAFROMN)>76
WRITE !!,$PIECE(PSAFROMN,"(IP)",1)_"(IP)",!?17,$PIECE(PSAFROMN,"(IP)",2)
if $LENGTH(PSAFROMN)<77
WRITE !?((80-$LENGTH(PSAFROMN))/2),PSAFROMN
+11 WRITE !!!,"TRANSFERRED TO: "
if $LENGTH(PSATON)>63
WRITE $PIECE(PSATON,"(IP)",1)_"(IP)",!?17,$PIECE(PSATON,"(IP)",2)
if $LENGTH(PSATON)<74
WRITE PSATON
WRITE !,PSASLN
+12 WRITE !,"TRANSFER DATE",?23,"QTY",?30,"DRUG",?68,"NEW BALANCE",!,PSASLN
+13 QUIT
