- PSDLBLP ;B'ham ISC/JPW - CS Print for Patient ID List ; 2 Mar 94
- ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
- I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)
- ;I '$D(^XUSEC("PSJ RNURSE",DUZ)) W !!,"Contact your Pharmacy Coordinator. You do not have the Supervisor",!,"access required to print labels.",!!
- ASK ;ask naou or ward
- S PSDOUT=0 N PSD2
- K DA,DIR,DIRUT S DIR(0)="SO^N:Nursing Location;W:Ward",DIR("A",1)="You may select Nursing Location or Ward to print the Patient ID List."
- S DIR("?",1)="Enter 'N' to select Nursing Location to print list",DIR("?")="Enter 'W' to select Ward to print list."
- S DIR("A")="Select Method" D ^DIR K DIR G:$D(DIRUT) END S ANS=Y
- I Y="N" D ASKN G:PSDOUT END G DEV
- WARD ;ask ward name
- W ! K DA,DIC
- F S DIC=42,DIC(0)="QEAM",DIC("A")="Select Ward to print Patient ID List: " D ^DIC G:$D(DTOUT)!($D(DUOUT))!((X="")&('$D(PSDW))) END Q:X="" D
- .S PSDW($P(Y,"^",2))=+Y_"^"_$P(Y,"^",2),PSDWN=$P(Y,"^",2)
- K DIC
- DEV S DIR(0)="SO^A:Alphabetical;R:Room-Bed",DIR("A")="Sort"
- D ^DIR K DIR G:$D(DIRUT) END S ANS(1)=Y
- ;ask device and queue info
- W !!,"This report is designed to print bar codes on a printer.",!,"You may queue this report to print at a later time.",!!
- K %ZIS,IOP,IO("Q"),POP S %ZIS="QM",%ZIS("B")="" D ^%ZIS I POP W !,"NO DEVICE SELECTED OR REPORT PRINTED!" G END
- I $D(IO("Q")) K IO("Q"),ZTSAVE,ZTDTH,ZTSK S ZTRTN="START^PSDLBLP",ZTDESC="Print Patient ID List for CS PHARM" D SAVE,^%ZTLOAD,HOME^%ZIS K ZTSK G END
- U IO
- START ;entry for compile and print labels
- K ^TMP("PSDLBLP",$J),PSDPRT S PSDCNT=0 D NOW^%DTC S PSDT=%
- F JJ=0,1 S @("PSDBAR"_JJ)="" I $D(^%ZIS(2,^%ZIS(1,IOS,"SUBTYPE"),"BAR"_JJ)) S @("PSDBAR"_JJ)=^("BAR"_JJ)
- I PSDBAR1]"",PSDBAR0]"" S PSDPRT=1
- G:ANS(1)="R" ^PSDLBLB
- 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,PATN,PSDCNT)=SSN_"^"_PSDRM
- 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
- S PSDN="" F S PSDN=$O(^TMP("PSDLBLP",$J,PSDN)) Q:PSDN=""!(PSDOUT) Q:PSDOUT D HDR 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 !,PSD,?45,$P(NODE,"^",2)," ",$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")="",ZTSAVE("ANS(1)")=""
- 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
- PSDLBLP ;B'ham ISC/JPW - CS Print for Patient ID List ; 2 Mar 94
- +1 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
- +2 IF '$DATA(PSDSITE)
- DO ^PSDSET
- IF '$DATA(PSDSITE)
- QUIT
- +3 ;I '$D(^XUSEC("PSJ RNURSE",DUZ)) W !!,"Contact your Pharmacy Coordinator. You do not have the Supervisor",!,"access required to print labels.",!!
- ASK ;ask naou or ward
- +1 SET PSDOUT=0
- NEW PSD2
- +2 KILL DA,DIR,DIRUT
- SET DIR(0)="SO^N:Nursing Location;W:Ward"
- SET DIR("A",1)="You may select Nursing Location or Ward to print the Patient ID List."
- +3 SET DIR("?",1)="Enter 'N' to select Nursing Location to print list"
- SET DIR("?")="Enter 'W' to select Ward to print list."
- +4 SET DIR("A")="Select Method"
- DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- GOTO END
- SET ANS=Y
- +5 IF Y="N"
- DO ASKN
- IF PSDOUT
- GOTO END
- GOTO DEV
- WARD ;ask ward name
- +1 WRITE !
- KILL DA,DIC
- +2 FOR
- SET DIC=42
- SET DIC(0)="QEAM"
- SET DIC("A")="Select Ward to print Patient ID List: "
- DO ^DIC
- IF $DATA(DTOUT)!($DATA(DUOUT))!((X="")&('$DATA(PSDW)))
- GOTO END
- IF X=""
- QUIT
- Begin DoDot:1
- +3 SET PSDW($PIECE(Y,"^",2))=+Y_"^"_$PIECE(Y,"^",2)
- SET PSDWN=$PIECE(Y,"^",2)
- End DoDot:1
- +4 KILL DIC
- DEV SET DIR(0)="SO^A:Alphabetical;R:Room-Bed"
- SET DIR("A")="Sort"
- +1 DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- GOTO END
- SET ANS(1)=Y
- +2 ;ask device and queue info
- +3 WRITE !!,"This report is designed to print bar codes on a printer.",!,"You may queue this report to print at a later time.",!!
- +4 KILL %ZIS,IOP,IO("Q"),POP
- SET %ZIS="QM"
- SET %ZIS("B")=""
- DO ^%ZIS
- IF POP
- WRITE !,"NO DEVICE SELECTED OR REPORT PRINTED!"
- GOTO END
- +5 IF $DATA(IO("Q"))
- KILL IO("Q"),ZTSAVE,ZTDTH,ZTSK
- SET ZTRTN="START^PSDLBLP"
- SET ZTDESC="Print Patient ID List for CS PHARM"
- DO SAVE
- DO ^%ZTLOAD
- DO HOME^%ZIS
- KILL ZTSK
- GOTO END
- +6 USE IO
- START ;entry for compile and print labels
- +1 KILL ^TMP("PSDLBLP",$JOB),PSDPRT
- SET PSDCNT=0
- DO NOW^%DTC
- SET PSDT=%
- +2 FOR JJ=0,1
- SET @("PSDBAR"_JJ)=""
- IF $DATA(^%ZIS(2,^%ZIS(1,IOS,"SUBTYPE"),"BAR"_JJ))
- SET @("PSDBAR"_JJ)=^("BAR"_JJ)
- +3 IF PSDBAR1]""
- IF PSDBAR0]""
- SET PSDPRT=1
- +4 IF ANS(1)="R"
- GOTO ^PSDLBLB
- +5 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
- +6 SET DFN=PSD1
- DO DEM^VADPT
- SET PATN=$SELECT('VAERR:VADM(1),1:"UNKNOWN")
- SET SSN=$PIECE(VADM(2),"^")
- SET PATN=PATN_" ("_VA("BID")_")"
- +7 SET VAINDT=PSDT
- DO INP^VADPT
- SET PSDRM=VAIN(5)
- +8 KILL DFN,VADM,VAIN,VAINDT
- +9 SET PSDCNT=PSDCNT+1
- SET ^TMP("PSDLBLP",$JOB,PSDWN,PATN,PSDCNT)=SSN_"^"_PSDRM
- 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 SET PSDN=""
- FOR
- SET PSDN=$ORDER(^TMP("PSDLBLP",$JOB,PSDN))
- IF PSDN=""!(PSDOUT)
- QUIT
- IF PSDOUT
- QUIT
- DO HDR
- Begin DoDot:1
- +4 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
- +5 IF $Y+26>IOSL
- DO HDR
- IF PSDOUT
- QUIT
- +6 WRITE !,PSD,?45,$PIECE(NODE,"^",2)," ",$GET(PSDN)
- +7 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")=""
- SET ZTSAVE("ANS(1)")=""
- +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
