- 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 Feb 18, 2025@23:17 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
