source: FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSASIG.m@ 636

Last change on this file since 636 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.2 KB
Line 
1PSASIG ;BIR/JMB-Transfer Signature Sheet ;7/23/97
2 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;; 10/24/97
3 ;This routine prints transfer signature sheets.
4 ;
5TEMP ;Entry point for printing immediately after transfer is entered. It is
6 ;called by PSATRAN1. All transactions are placed in ^TMP("PSASIG",$J)
7 ;while inputing the transaction. The transfer sheets are printed using
8 ;this array.
9 W ! S %ZIS="Q" D ^%ZIS G:POP EXIT
10 I $D(IO("Q")) D G EXIT
11 .S ZTDESC="Drug Acct.-Print Transfer Signature Sheets",ZTRTN="TQUE^PSASIG"
12 .S ZTSAVE("^TMP(""PSASIG"",$J,")="" D ^%ZTLOAD
13TQUE S PSAOUT=0,PSAFIRST=1,PSASLN="",$P(PSASLN,"-",80)="",PSADLN="",$P(PSADLN,"=",80)=""
14 D NOW^%DTC S Y=+$E(%,1,12) X ^DD("DD") S PSARPDT=Y
15 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
16 .S PSAPG=0,PSALOC=PSAFROM D SITES^PSAUTL1 S PSAFROMN=$P(^PSD(58.8,PSALOC,0),"^")_PSACOMB
17 .S PSALOC=PSATO D SITES^PSAUTL1 S PSATON=$P(^PSD(58.8,PSALOC,0),"^")_PSACOMB
18 .D HDR Q:PSAOUT
19 .S PSADA=0 F S PSADA=$O(^TMP("PSASIG",$J,PSAFROM,PSATO,PSADA)) Q:'PSADA!(PSAOUT) D PRINT S PSAFIRST=0
20EXIT I $E(IOST)'="C" W @IOF
21 I $E(IOST,1,2)="C-",'PSAOUT D
22 .S PSASS=21-$Y F PSAKK=1:1:PSASS W !
23 .S DIR(0)="E",DIR("A")="END OF REPORT! Press <RET> to return to the menu" D ^DIR K DIR W @IOF
24 D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" K IO("Q")
25 K ^TMP("PSASIG",$J),%,%ZIS,DIR,DTOUT,PSABAL,PSABEG,PSACHK,PSACNT,PSACOMB,PSADA,PSADLN,PSADRG,PSADT,PSAEND,PSAFIRST,PSAFROM,PSAFROMN,PSAKK
26 K PSALOC,PSALOCA,PSALOCN,PSANODE,PSAOUT,PSAPG,PSAQTY,PSAREPRT,PSARPDT,PSASAVE,PSASEL,PSASLN,PSASS,PSATO,PSATON,PSATRAN,PSATRDT,PSAWHO,Y,ZTDESC,ZTRTN,ZTSAVE
27 Q
28 ;
29REPRINT ;Entry point for Transfer Signature Sheets. It prompts for the
30 ;dispensing pharmacy location, receiving pharmacy location, beginning
31 ;date, then ending date.
32 S PSAREPRT=1,(PSACNT,PSAOUT)=0,PSATRAN="F"
33 D ^PSAUTL3 G:PSAOUT EXIT S PSACNT=0,PSACHK=$O(PSALOC(""))
34 I PSACHK="",'PSALOC W !,"There are no active pharmacy locations." G EXIT
35 S PSAFROM=+PSALOC,PSAFROMN=PSALOCN D TO^PSATRAN
36 D BDATE^PSAPV
37 W ! S %ZIS="Q" D ^%ZIS G:POP EXIT
38 I $D(IO("Q")) D G EXIT
39 .S ZTDESC="Drug Acct.-Reprint Transfer Signature Sheets",ZTRTN="RQUE^PSASIG"
40 .F PSASAVE="PSABEG","PSAEND","PSAFROM","PSAFROMN","PSATO","PSATON" S:$D(PSASAVE) ZTSAVE(PSASAVE)=""
41 .S ZTSAVE("^TMP(""PSASIG"",$J,")="" D ^%ZTLOAD
42RQUE S (PSAPG,PSAOUT)=0,PSAREPRT=1,PSASLN="",$P(PSASLN,"-",80)="",PSADLN="",$P(PSADLN,"=",80)="",PSADT=PSABEG
43 D NOW^%DTC S Y=+$E(%,1,12) X ^DD("DD") S PSARPDT=Y,PSAFIRST=1
44 D HDR S PSAFIRST=0
45 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
46 .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
47 G EXIT
48 ;
49PRINT S PSANODE=$G(^PSD(58.81,PSADA,0)),PSATRDT=$E($$FMTE^XLFDT($P(PSANODE,"^",4),1),1,18),PSADRG=$P(PSANODE,"^",5)
50 S PSAQTY=$P(PSANODE,"^",6),PSAWHO=$P($G(^VA(200,+$P(PSANODE,"^",7),0)),"^"),PSABAL=+$P(PSANODE,"^",10)
51 S:PSAQTY<0 PSAQTY=-PSAQTY D:$Y+7>IOSL HDR Q:PSAOUT
52 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")
53 W !!,?2,"Dispensed by: "_$S(PSAWHO'="":PSAWHO,1:"_____________________"),?40,"Rec'd by: ____________________________"
54 W !,?20,"(Full Name)",?55,"(Full Name)",!,PSADLN
55 Q
56 ;
57HDR ;Header
58 I $E(IOST,1,2)="C-",'PSAFIRST D I 'Y S PSAOUT=1 Q
59 .S PSASS=21-$Y F PSAKK=1:1:PSASS W !
60 .S DIR(0)="E" D ^DIR K DIR
61 I $E(IOST,1,2)="C-",'PSAPG W @IOF
62 W:$E(IOST,1,2)'="C-"&('PSAPG)&('PSAFIRST) @IOF
63 W:PSAPG @IOF S PSAPG=PSAPG+1
64 W:$G(PSAREPRT) !,?32,"*** REPRINT ***"
65 W !,PSARPDT,?20,"DRUG ACCOUNTABILITY/INVENTORY INTERFACE",?72,"Page: ",PSAPG
66 W !?18,"DRUG TRANSFER BETWEEN PHARMACIES SIGNATURE SHEET"
67 W:$L(PSAFROMN)>76 !!,$P(PSAFROMN,"(IP)",1)_"(IP)",!?17,$P(PSAFROMN,"(IP)",2) W:$L(PSAFROMN)<77 !?((80-$L(PSAFROMN))/2),PSAFROMN
68 W !!!,"TRANSFERRED TO: " W:$L(PSATON)>63 $P(PSATON,"(IP)",1)_"(IP)",!?17,$P(PSATON,"(IP)",2) W:$L(PSATON)<74 PSATON W !,PSASLN
69 W !,"TRANSFER DATE",?23,"QTY",?30,"DRUG",?68,"NEW BALANCE",!,PSASLN
70 Q
Note: See TracBrowser for help on using the repository browser.