source: WorldVistAEHR/trunk/r/CONTROLLED_SUBSTANCES-PSD/PSDPGS1.m@ 1742

Last change on this file since 1742 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 5.1 KB
Line 
1PSDPGS1 ;BIR/JPW-Print Green Sheet (VA FORM 10-2638 ) (cont'd) ; 3 Mar 98
2 ;;3.0; CONTROLLED SUBSTANCES ;**8,46**;13 Feb 97
3 ;Y2K compliance** display 4 digit year on va forms
4START ;loop through transactions
5 ;second call to %ZIS to restore variables for open execute
6 I $D(ZTQUEUED) S IOP=ION D ^%ZIS U IO
7 ;get ready for bar codes and formatting
8 N PSD10,PSD12,PSDL,A7BAR0,A7BAR1
9 D A7BAR
10 S PSD10=$P($G(^%ZIS(2,+$G(IOST(0)),5)),U),PSD12=$P($G(^(5)),U,2)
11 S PSDL=$P($G(^%ZIS(2,+$G(IOST(0)),12.16)),U)
12 S PSDL(1)=$P($G(^%ZIS(2,+$G(IOST(0)),12.15)),U)
13 I PSD12']""!(PSD10']"")!(PSDL']"")!(PSDL(1)']"") W !!,"The device you selected is not set up for green sheets, please contact IRM.",!! Q
14 K ^TMP("PSDPGS",$J)
15 S PSDCNT=1
16 I ANS="R" S PSD1="" F S PSD1=$O(PSD1(PSD1)) Q:PSD1="" D LOOP
17 I ANS="R" G PRINT
18 I ANS="N",$D(PSDG) F PSD=0:0 S PSD=$O(PSDG(PSD)) Q:'PSD F PSDN=0:0 S PSDN=$O(^PSI(58.2,PSD,3,PSDN)) Q:'PSDN I $D(^PSD(58.8,PSDN,0)),'$P(^(0),"^",7),$P(^(0),"^",3)=+PSDSITE S NAOU(PSDN)="",CNT=CNT+1
19 I ANS="N",$D(ALL) F PSD=0:0 S PSD=$O(^PSD(58.8,PSD)) Q:'PSD I $D(^PSD(58.8,PSD,0)),$P(^(0),"^",2)="N",$P(^(0),"^",3)=+PSDSITE S NAOU(+PSD)=""
20 S LOOP=$S(PRT:2,1:3)
21 F STAT=LOOP-.99:0 S STAT=$O(^PSD(58.81,"AD",STAT)) Q:'STAT!(STAT>3) F PSD=0:0 S PSD=$O(^PSD(58.81,"AD",STAT,PSD)) Q:'PSD F PSDA=0:0 S PSDA=$O(^PSD(58.81,"AD",STAT,PSD,PSDA)) Q:'PSDA D SET
22PRINT ;print green sheet
23 I '$D(^TMP("PSDPGS",$J)) W !,"*** SORRY NO GREEN SHEETS TO PRINT ***",! G END
24 S PSDPN="" F S PSDPN=$O(^TMP("PSDPGS",$J,PSDPN)) Q:PSDPN="" D
25 .S NODE=^TMP("PSDPGS",$J,PSDPN),NAOUN=$P(NODE,"^"),PSDBYN=$P(NODE,"^",5),PSDT=$P(NODE,"^",6),ORDN=$P(NODE,"^",7)
26 .I ORDN]"",ORDN'="UNKNOWN" S ORDN=$P(ORDN,",")_","_$E($P(ORDN,",",2))
27 .I PSDBYN]"",PSDBYN'="UNKNOWN" S PSDBYN=$P(PSDBYN,",")_","_$E($P(PSDBYN,",",2))
28 .S PSDDT="" I PSDT S Y=PSDT X ^DD("DD") S PSDYR=$P(Y,",",2),PSDYR=$E(PSDYR,1,4) S PSDDT=$E(PSDT,4,5)_"/"_$E(PSDT,6,7)_"/"_PSDYR
29 .W:$Y @IOF,@PSD12 W ?33,NAOUN," ",$P($G(^DPT(+$P(NODE,U,9),0)),U)
30 .I $D(A7PRT) W $C(13),?70,@A7BAR1,@PSD10,PSDPN,@A7BAR0,@PSD12
31 .W @PSDL,!?6,"CONTROLLED SUBSTANCE ADMINISTRATION RECORD",?54
32 .W "Pharmacy Dispensing # ",@PSD10,PSDPN,@PSD12,!?6
33 .W "Drug: ",@PSD10,$P(NODE,U,2),@PSD12,?60,"Exp: ",$P(NODE,U,4),?78
34 .W "Qty: ",@PSD10,$P(NODE,U,3),@PSD12,!?6
35 .W "Lot#",$P(NODE,U,8),?21,"Ord by: ",$E(ORDN,1,20)
36 .W ?45,"Disp by: ",$E(PSDBYN,1,20),?70,"Date: ",PSDDT,@PSDL(1),!?7
37 .S $P(LN,"_",80)="" W LN,@PSDL,!?6
38 .W "| DATE TIME NAME OF PATIENT DOSE BALANCE ADMINISTERED BY |"
39 .F LINE=1:1:30 W !?6,"|________|_____|_______________________|_____|______|___________________________|"
40 .W !?6,"Above Drug Received: Date__________ R.N. Sign_______________________________"
41 .W !?6,"Above Drug Administered: Date__________ R.N. Sign_______________________________"
42 .W !?6,"Entries Reviewed: Date__________ R.PH. Sign______________________________",!?6
43 .W @PSDL(1),"Drug: ",@PSD10,$P(NODE,U,2),@PSD12,?60
44 .W "Pharmacy Dispensing # ",@PSD10,PSDPN,@PSD12,!?6
45 .W "Automated VA FORM 10-2638"
46END K %ZIS,ALL,ANS,ASK,C,CNT,D,DA,DIC,DIE,DIR,DIROUT,DIRUT,DR,DTOUT,DUOUT,EXP,EXPD,IOP,JJ,LINE,LOOP,LOT,NAOU,NAOUN,NODE,NODE1
47 K OK,ORD,ORDN,POP,PRT,PSD,PSD1,PSDA,PSDBY,PSDBYN,PSDCPI,PSDCNT,PSDDT,PSDEV,PSDG,PSDN,PSDOUT,PSDPN,PSDR,PSDRN,PSDS,PSDSN,PSDT,PSDYR
48 K QTY,SEL,SITE,STAT,X,Y,ZTDESC,ZTDTH,ZTRTN,ZTSAVE,ZTSK
49 K ^TMP("PSDPGS",$J)
50 D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
51 Q
52LOOP S PSDPN=$P(PSD1(PSD1),",",PSDCNT),PSDCNT=PSDCNT+1 I PSDPN="" S PSDCNT=1 Q
53 S PSDA=$O(^PSD(58.81,"D",PSDPN,0)),PSD=+$P($G(^PSD(58.81,+PSDA,0)),"^",18) D SET
54 G LOOP
55 Q
56SET ;set data for printing
57 Q:'$D(^PSD(58.81,+PSDA,0)) Q:+$P($G(^PSD(58.81,+PSDA,0)),"^",3)'=+PSDS
58 Q:+$P($G(^PSD(58.8,+PSD,2)),"^",5)&('$P($G(^PSD(58.8,+PSDS,1,+$P($G(^PSD(58.81,+PSDA,0)),U,5),7)),U,3))&('$P($G(^PSD(58.81,+PSDA,9)),U))
59 Q:+$P($G(^PSD(58.81,+PSDA,"CS")),"^",4)
60 I ANS="N" Q:'$D(NAOU(+PSD))
61 S NODE=^PSD(58.81,+PSDA,0) Q:+$P(NODE,"^",11)>3
62 S NAOUN=$S($P($G(^PSD(58.8,+PSD,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
63 S PSDR=+$P(NODE,"^",5),PSDRN=$S($P($G(^PSDRUG(PSDR,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
64 S PSDPN=$S($P(NODE,"^",17)]"":$P(NODE,"^",17),1:"UNKNOWN"),PSDT=$P(NODE,"^",4)
65 S QTY=$P(NODE,"^",6) I $D(^PSD(58.81,PSDA,4)),+$P(^(4),"^",3) S QTY=$P(^(4),"^",3)
66 S LOT=$P(NODE,"^",14),EXP=$P(NODE,"^",15),EXPD="" I EXP S Y=$E(EXP,1,7) X ^DD("DD") S EXPD=Y
67 S (PSDBY,PSDBYN,ORD,ORDN)=""
68 I $D(^PSD(58.81,PSDA,1)) S NODE1=^(1),PSDBY=$P(NODE1,"^"),ORD=$P(NODE1,"^",7)
69 S:ORD ORDN=$S($P($G(^VA(200,ORD,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
70 S:PSDBY PSDBYN=$S($P($G(^VA(200,PSDBY,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
71 S ^TMP("PSDPGS",$J,PSDPN)=NAOUN_"^"_PSDRN_"^"_QTY_"^"_EXPD_"^"_PSDBYN_"^"_PSDT_"^"_ORDN_"^"_LOT_U_$P($G(^PSD(58.81,PSDA,9)),U)
72 K DA,DIE,DR S DA=PSDA,DIE=58.81,DR="103////1" D ^DIE K DA,DIE,DR
73 Q
74A7BAR ;DALISC/JRR set up vars to print barcode on green sheet
75 ;This subroutine added by James Reed, Dallas ISC, 9/8/95
76 K A7PRT ;Var will be defined if bar code logic was set up in device file
77 F JJ=0,1 S @("A7BAR"_JJ)="" I $D(^%ZIS(2,^%ZIS(1,IOS,"SUBTYPE"),"BAR"_JJ)) S @("A7BAR"_JJ)=^("BAR"_JJ)
78 I A7BAR1]"",A7BAR0]"" S A7PRT=1 ;okay to print bar code
Note: See TracBrowser for help on using the repository browser.