source: WorldVistAEHR/trunk/r/CONTROLLED_SUBSTANCES-PSD/PSDLBLB.m@ 701

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

initial load of WorldVistAEHR

File size: 2.7 KB
Line 
1PSDLBLB ;B'ham ISC/JPW - CS Print for Patient ID List ; 2 Mar 94
2 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
3 S PSDWN="" F S PSDWN=$O(PSDW(PSDWN)) Q:PSDWN="" F PSD1=0:0 S PSD1=$O(^DPT("ACN",PSDWN,PSD1)) Q:'PSD1 I $D(^DPT(PSD1,0)) D
4 .S DFN=PSD1 D DEM^VADPT S PATN=$S('VAERR:VADM(1),1:"UNKNOWN"),SSN=$P(VADM(2),"^"),PATN=PATN_" ("_VA("BID")_")"
5 .S VAINDT=PSDT D INP^VADPT S PSDRM=VAIN(5)
6 .K DFN,VADM,VAIN,VAINDT
7 .S PSDCNT=PSDCNT+1,^TMP("PSDLBLP",$J,PSDWN,$S(PSDRM]"":PSDRM,1:0),PSDCNT)=SSN_"^"_PATN
8PRINT ;print labels
9 S (PSDOUT,PG)=0,$P(LN,"-",80)="",(PSDX1,PSDCNT)=1
10 I '$D(^TMP("PSDLBLP",$J)) D HDR W !!,?15,"**** NO PATIENT WARD INFO ****",!! G DONE
11 D HDR
12 S PSDN="" F S PSDN=$O(^TMP("PSDLBLP",$J,PSDN)) Q:PSDN=""!(PSDOUT) Q:PSDOUT D Q:PSDOUT
13 .S PSD="" F S PSD=$O(^TMP("PSDLBLP",$J,PSDN,PSD)) Q:PSD=""!(PSDOUT) D:$Y+26>IOSL HDR Q:PSDOUT F PSD1=0:0 S PSD1=$O(^TMP("PSDLBLP",$J,PSDN,PSD,PSD1)) Q:'PSD1!(PSDOUT) S NODE=^(PSD1) D
14 ..I $Y+26>IOSL D HDR Q:PSDOUT
15 ..W !,$P(NODE,U,2),?45,$S(PSD=0:"NONE",1:PSD)," ",$G(PSDN)
16 ..W ! I $D(PSDPRT) W @PSDBAR1,$P(NODE,"^"),@PSDBAR0,!!
17DONE I $E(IOST)'="C" W @IOF
18 I $E(IOST,1,2)="C-",'PSDOUT W ! K DIR,DIRUT S DIR(0)="EA",DIR("A")="END OF REPORT! Press <RET> to return to the menu" D ^DIR K DIR
19END ;kill variables and exit
20 D KVAR^VADPT K VA
21 K %,%H,%ZIS,ANS,DA,DFN,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,JJ,JJ1,JJ2,LN,NODE,POP,PATN,PG,PSD,PSD1,PSDBAR0,PSDBAR1,PSDCNT,PSDN,PSDOUT
22 K PSDPRT,PSDR,PSDRM,PSDT,PSDW,PSDWN,PSDX1,PSDX2,SSN,VADM,VAERR,VAIN,VAINDT,X,Y,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK
23 K ^TMP("PSDLBLP",$J)
24 D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
25 Q
26HDR ;prints header information
27 I $E(IOST,1,2)="C-",PG K DA,DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSDOUT=1 Q
28 S PG=PG+1,PSD(1)=0 W:$Y @IOF W !,"Patient ID List for "
29 ;F S PSD(1)=$O(PSDW(PSD(1))) Q:PSD(1)']"" W PSD(1)
30 W $S($G(PSD2)]"":PSD2,$G(PSDN)]"":PSDN,$G(NAOUN)]"":NAOUN,$O(PSDW(""))]"":$O(PSDW("")),1:"")
31 W " Printed: ",$$HTE^XLFDT($H,"P"),?70,"Page: ",PG,!
32 W "PATIENT",?45,"ROOM-BED",!,LN,!!
33 Q
34SAVE ;save queued variables
35 S ZTSAVE("PSDW(")="",ZTSAVE("PSD2")=""
36 S:$D(NAOUN) ZTSAVE("NAOUN")=""
37 Q
38ASKN ;ask nursing location
39 K DA,DIC S DIC=211.4,DIC(0)="QEA",DIC("A")="Select Nursing Location: "
40 W ! D ^DIC K DIC I Y<0 S PSDOUT=1 Q
41 N PSD S PSD2=$P($P($G(^SC(+$P(Y,U,2),0)),U)," ",2)
42 D GETS^DIQ(211.4,+Y_",","2*","","PSD") S PSD(1)=0
43 F S PSD(1)=$O(PSD(211.41,PSD(1))) Q:PSD(1)']"" D:$G(PSD(211.41,PSD(1),.01))]""
44 .S PSDW($G(PSD(211.41,PSD(1),.01)))=0
45 Q
46WARD2 W !!,"Compiling Ward data for ",NAOUN,"..."
47 F JJ=0:0 S JJ=$O(^PSD(58.8,"D",JJ)) Q:'JJ F JJ1=0:0 S JJ1=$O(^PSD(58.8,"D",JJ,JJ1)) Q:'JJ1 F JJ2=0:0 S JJ2=$O(^PSD(58.8,"D",JJ,JJ1,JJ2)) Q:('JJ2)!(JJ2'=NAOU) D
48 .Q:$P($G(^DIC(42,+JJ1,0)),"^")']""
49 .S PSDW($P($G(^DIC(42,+JJ1,0)),"^"))=+JJ1_"^"_$P($G(^DIC(42,+JJ1,0)),"^")
50 Q
Note: See TracBrowser for help on using the repository browser.