PSDLBLB ;B'ham ISC/JPW - CS Print for Patient ID List ; 2 Mar 94
;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
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
.S DFN=PSD1 D DEM^VADPT S PATN=$S('VAERR:VADM(1),1:"UNKNOWN"),SSN=$P(VADM(2),"^"),PATN=PATN_" ("_VA("BID")_")"
.S VAINDT=PSDT D INP^VADPT S PSDRM=VAIN(5)
.K DFN,VADM,VAIN,VAINDT
.S PSDCNT=PSDCNT+1,^TMP("PSDLBLP",$J,PSDWN,$S(PSDRM]"":PSDRM,1:0),PSDCNT)=SSN_"^"_PATN
PRINT ;print labels
S (PSDOUT,PG)=0,$P(LN,"-",80)="",(PSDX1,PSDCNT)=1
I '$D(^TMP("PSDLBLP",$J)) D HDR W !!,?15,"**** NO PATIENT WARD INFO ****",!! G DONE
D HDR
S PSDN="" F S PSDN=$O(^TMP("PSDLBLP",$J,PSDN)) Q:PSDN=""!(PSDOUT) Q:PSDOUT D Q:PSDOUT
.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
..I $Y+26>IOSL D HDR Q:PSDOUT
..W !,$P(NODE,U,2),?45,$S(PSD=0:"NONE",1:PSD)," ",$G(PSDN)
..W ! I $D(PSDPRT) W @PSDBAR1,$P(NODE,"^"),@PSDBAR0,!!
DONE I $E(IOST)'="C" W @IOF
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
END ;kill variables and exit
D KVAR^VADPT K VA
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
K PSDPRT,PSDR,PSDRM,PSDT,PSDW,PSDWN,PSDX1,PSDX2,SSN,VADM,VAERR,VAIN,VAINDT,X,Y,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK
K ^TMP("PSDLBLP",$J)
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
HDR ;prints header information
I $E(IOST,1,2)="C-",PG K DA,DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSDOUT=1 Q
S PG=PG+1,PSD(1)=0 W:$Y @IOF W !,"Patient ID List for "
;F S PSD(1)=$O(PSDW(PSD(1))) Q:PSD(1)']"" W PSD(1)
W $S($G(PSD2)]"":PSD2,$G(PSDN)]"":PSDN,$G(NAOUN)]"":NAOUN,$O(PSDW(""))]"":$O(PSDW("")),1:"")
W " Printed: ",$$HTE^XLFDT($H,"P"),?70,"Page: ",PG,!
W "PATIENT",?45,"ROOM-BED",!,LN,!!
Q
SAVE ;save queued variables
S ZTSAVE("PSDW(")="",ZTSAVE("PSD2")=""
S:$D(NAOUN) ZTSAVE("NAOUN")=""
Q
ASKN ;ask nursing location
K DA,DIC S DIC=211.4,DIC(0)="QEA",DIC("A")="Select Nursing Location: "
W ! D ^DIC K DIC I Y<0 S PSDOUT=1 Q
N PSD S PSD2=$P($P($G(^SC(+$P(Y,U,2),0)),U)," ",2)
D GETS^DIQ(211.4,+Y_",","2*","","PSD") S PSD(1)=0
F S PSD(1)=$O(PSD(211.41,PSD(1))) Q:PSD(1)']"" D:$G(PSD(211.41,PSD(1),.01))]""
.S PSDW($G(PSD(211.41,PSD(1),.01)))=0
Q
WARD2 W !!,"Compiling Ward data for ",NAOUN,"..."
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
.Q:$P($G(^DIC(42,+JJ1,0)),"^")']""
.S PSDW($P($G(^DIC(42,+JJ1,0)),"^"))=+JJ1_"^"_$P($G(^DIC(42,+JJ1,0)),"^")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDLBLB 2853 printed Oct 16, 2024@17:47:25 Page 2
PSDLBLB ;B'ham ISC/JPW - CS Print for Patient ID List ; 2 Mar 94
+1 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
+2 SET PSDWN=""
FOR
SET PSDWN=$ORDER(PSDW(PSDWN))
if PSDWN=""
QUIT
FOR PSD1=0:0
SET PSD1=$ORDER(^DPT("ACN",PSDWN,PSD1))
if 'PSD1
QUIT
IF $DATA(^DPT(PSD1,0))
Begin DoDot:1
+3 SET DFN=PSD1
DO DEM^VADPT
SET PATN=$SELECT('VAERR:VADM(1),1:"UNKNOWN")
SET SSN=$PIECE(VADM(2),"^")
SET PATN=PATN_" ("_VA("BID")_")"
+4 SET VAINDT=PSDT
DO INP^VADPT
SET PSDRM=VAIN(5)
+5 KILL DFN,VADM,VAIN,VAINDT
+6 SET PSDCNT=PSDCNT+1
SET ^TMP("PSDLBLP",$JOB,PSDWN,$SELECT(PSDRM]"":PSDRM,1:0),PSDCNT)=SSN_"^"_PATN
End DoDot:1
PRINT ;print labels
+1 SET (PSDOUT,PG)=0
SET $PIECE(LN,"-",80)=""
SET (PSDX1,PSDCNT)=1
+2 IF '$DATA(^TMP("PSDLBLP",$JOB))
DO HDR
WRITE !!,?15,"**** NO PATIENT WARD INFO ****",!!
GOTO DONE
+3 DO HDR
+4 SET PSDN=""
FOR
SET PSDN=$ORDER(^TMP("PSDLBLP",$JOB,PSDN))
if PSDN=""!(PSDOUT)
QUIT
if PSDOUT
QUIT
Begin DoDot:1
+5 SET PSD=""
FOR
SET PSD=$ORDER(^TMP("PSDLBLP",$JOB,PSDN,PSD))
if PSD=""!(PSDOUT)
QUIT
if $Y+26>IOSL
DO HDR
if PSDOUT
QUIT
FOR PSD1=0:0
SET PSD1=$ORDER(^TMP("PSDLBLP",$JOB,PSDN,PSD,PSD1))
if 'PSD1!(PSDOUT)
QUIT
SET NODE=^(PSD1)
Begin DoDot:2
+6 IF $Y+26>IOSL
DO HDR
if PSDOUT
QUIT
+7 WRITE !,$PIECE(NODE,U,2),?45,$SELECT(PSD=0:"NONE",1:PSD)," ",$GET(PSDN)
+8 WRITE !
IF $DATA(PSDPRT)
WRITE @PSDBAR1,$PIECE(NODE,"^"),@PSDBAR0,!!
End DoDot:2
End DoDot:1
if PSDOUT
QUIT
DONE IF $EXTRACT(IOST)'="C"
WRITE @IOF
+1 IF $EXTRACT(IOST,1,2)="C-"
IF 'PSDOUT
WRITE !
KILL DIR,DIRUT
SET DIR(0)="EA"
SET DIR("A")="END OF REPORT! Press <RET> to return to the menu"
DO ^DIR
KILL DIR
END ;kill variables and exit
+1 DO KVAR^VADPT
KILL VA
+2 KILL %,%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
+3 KILL PSDPRT,PSDR,PSDRM,PSDT,PSDW,PSDWN,PSDX1,PSDX2,SSN,VADM,VAERR,VAIN,VAINDT,X,Y,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK
+4 KILL ^TMP("PSDLBLP",$JOB)
+5 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+6 QUIT
HDR ;prints header information
+1 IF $EXTRACT(IOST,1,2)="C-"
IF PG
KILL DA,DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET PSDOUT=1
QUIT
+2 SET PG=PG+1
SET PSD(1)=0
if $Y
WRITE @IOF
WRITE !,"Patient ID List for "
+3 ;F S PSD(1)=$O(PSDW(PSD(1))) Q:PSD(1)']"" W PSD(1)
+4 WRITE $SELECT($GET(PSD2)]"":PSD2,$GET(PSDN)]"":PSDN,$GET(NAOUN)]"":NAOUN,$ORDER(PSDW(""))]"":$ORDER(PSDW("")),1:"")
+5 WRITE " Printed: ",$$HTE^XLFDT($HOROLOG,"P"),?70,"Page: ",PG,!
+6 WRITE "PATIENT",?45,"ROOM-BED",!,LN,!!
+7 QUIT
SAVE ;save queued variables
+1 SET ZTSAVE("PSDW(")=""
SET ZTSAVE("PSD2")=""
+2 if $DATA(NAOUN)
SET ZTSAVE("NAOUN")=""
+3 QUIT
ASKN ;ask nursing location
+1 KILL DA,DIC
SET DIC=211.4
SET DIC(0)="QEA"
SET DIC("A")="Select Nursing Location: "
+2 WRITE !
DO ^DIC
KILL DIC
IF Y<0
SET PSDOUT=1
QUIT
+3 NEW PSD
SET PSD2=$PIECE($PIECE($GET(^SC(+$PIECE(Y,U,2),0)),U)," ",2)
+4 DO GETS^DIQ(211.4,+Y_",","2*","","PSD")
SET PSD(1)=0
+5 FOR
SET PSD(1)=$ORDER(PSD(211.41,PSD(1)))
if PSD(1)']""
QUIT
if $GET(PSD(211.41,PSD(1),.01))]""
Begin DoDot:1
+6 SET PSDW($GET(PSD(211.41,PSD(1),.01)))=0
End DoDot:1
+7 QUIT
WARD2 WRITE !!,"Compiling Ward data for ",NAOUN,"..."
+1 FOR JJ=0:0
SET JJ=$ORDER(^PSD(58.8,"D",JJ))
if 'JJ
QUIT
FOR JJ1=0:0
SET JJ1=$ORDER(^PSD(58.8,"D",JJ,JJ1))
if 'JJ1
QUIT
FOR JJ2=0:0
SET JJ2=$ORDER(^PSD(58.8,"D",JJ,JJ1,JJ2))
if ('JJ2)!(JJ2'=NAOU)
QUIT
Begin DoDot:1
+2 if $PIECE($GET(^DIC(42,+JJ1,0)),"^")']""
QUIT
+3 SET PSDW($PIECE($GET(^DIC(42,+JJ1,0)),"^"))=+JJ1_"^"_$PIECE($GET(^DIC(42,+JJ1,0)),"^")
End DoDot:1
+4 QUIT
