DGPLBL ;ALB/RPM - PATIENT INFORMATION LABELS ; 05/07/04
;;5.3;Registration;**571**;Aug 13, 1993
;
;This routine provides a generic patient demographics label
;print that includes Patient Name, SSN, DOB and an optional
;inpatient location (ward and bed). Support for various printer
;types (i.e. bar code, laser, etc.) is provided using the CONTROL
;CODES (#3.2055) subfile of the TERMINAL TYPE (#3.2) file. The
;control code mnemonics are documented in DBIA# 3435.
;
Q ;no direct entry
;
EN ;main entry point used by DG PRINT PATIENT LABEL option
;
N DGDFNS ;selected patients array
N DGIOCC ;control codes array
N DGLBCNT ;label count
N DGLPL ;lines per label
N DGLOC ;include location flag (0 or 1)
N DGQVAR ;queuing variables
;
;select list of patients to print
Q:'$$SELPATS("DGDFNS")
;
S DGLOC=$$ASK("Include Inpatient Location on Label","Y","YES","Answer YES to include the inpatient ward and bed location on the label")
Q:(DGLOC<0)
;
S DGLBCNT=$$ASK("Number of Labels per patient",1,"NO^1:250:0","Enter the number of labels to print per patient, from 1 to 250")
Q:(DGLBCNT<0)
;
S DGLPL=$$ASK("Number of Lines per Label",6,"NO^6:25:0","Enter the total number of lines that the label stock can contain (6-25)")
Q:(DGLPL<0)
;
;
;init queued variables and select output device
S DGQVAR("DGDFNS(")=""
S DGQVAR("DGLBCNT")=""
S DGQVAR("DGLPL")=""
S DGQVAR("DGLOC")=""
D EN^XUTMDEVQ("START^DGPLBL","DG PRINT PATIENT LABEL",.DGQVAR)
Q
;
START ;retrieve label field data and print labels
;
; Input:
; DGDFNS - array subscripted by pointer to PATIENT (#2) file
; DGLBCNT - number of labels to print per patient
; DGLPL - number of lines per label
; DGLOC - print ward location flag
;
; Output:
; none
;
N DGDFN ;pointer to PATIENT file
N DGI,DGJ ;generic counters
N DGIOCC ;printer Control Codes
N DGLN ;line array index
N DGLNCNT ;line count
N DGLINE ;line text
;
;initialize printer
S DGIOCC=$$LOADCC(.DGIOCC)
I DGIOCC,$G(DGIOCC("FI"))]"" X DGIOCC("FI") ;format initialize
;
;for each patient
S DGDFN=0
F S DGDFN=$O(DGDFNS(DGDFN)) Q:'DGDFN D
. ;
. ;build text line array
. S DGLNCNT=$$BLDLNAR(DGDFN,DGLOC,.DGLINE)
. Q:'DGLNCNT
. ;
. ;print patient's labels
. F DGI=1:1:DGLBCNT D
. . I DGIOCC,$G(DGIOCC("SL"))]"" X DGIOCC("SL") ;start of label
. . ;for each line
. . F DGLN=1:1:DGLNCNT D
. . . I DGIOCC,$G(DGIOCC("ST"))]"" X DGIOCC("ST") ;start text
. . . I DGIOCC,$G(DGIOCC("STF"))]"" X DGIOCC("STF") ;start text field
. . . W $G(DGLINE(DGLN))
. . . I DGIOCC,$G(DGIOCC("ETF"))]"" X DGIOCC("ETF") ;end text field
. . . I DGIOCC,$G(DGIOCC("ET"))]"" X DGIOCC("ET") ;end text
. . . I 'DGIOCC W !
. . I DGIOCC,$G(DGIOCC("EL"))]"" X DGIOCC("EL") ;end of label
. . I 'DGIOCC,DGLNCNT<DGLPL F DGJ=1:1:(DGLPL-DGLNCNT) W !
I DGIOCC,$G(DGIOCC("FE"))]"" X DGIOCC("FE") ;format end
;
D END
;
Q
;
SELPATS(DGARR) ;select patient(s) to print
;
; Input:
; DGARR - array name to contain returned patients
;
; Output:
; Function value - 1 on success; 0 on failure
; DGARR - array of returned patients on success
;
N DIC ;FM file reference
N VAUTVB ;contains name of subscripted variable to return
N VAUTNALL ;define to prevent "ALL" option
N VAUTSTR ;prompt string following "Select "
N VAUTNI ;sort type flag [1:alpha if .01 not pointer,2:numeric,
; 3:alpha]
;
S DIC="^DPT(",VAUTVB=DGARR,VAUTNALL=1,VAUTNI=2,VAUTSTR="PATIENT"
D FIRST^VAUTOMA
Q $S($O(@DGARR@("")):1,1:0)
;
;
ASK(DGDIRA,DGDIRB,DGDIR0,DGDIRH) ;
; Input
; DGDIR0 - DIR(0) string
; DGDIRA - DIR("A") string
; DGDIRB - DIR("B") string
; DGDIRH - DIR("?") string
;
; Output
; Function Value - Internal value returned from ^DIR or -1 if user
; up-arrows, double up-arrows or the read times out.
;
; DIR(0) type Results
; ------------ -------------------------------
; DD IEN of selected entry
; Numeric Value of number entered by user
; Pointer IEN of selected entry
; Set of Codes Internal value of code
; Yes/No 0 for No, 1 for Yes
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y ;^DIR variables
;
S DIR(0)=DGDIR0
S DIR("A")=$G(DGDIRA)
I $G(DGDIRB)]"" S DIR("B")=DGDIRB
I $G(DGDIRH)]"" S DIR("?")=DGDIRH
D ^DIR
Q $S($D(DUOUT):-1,$D(DTOUT):-1,$D(DIROUT):-1,X="@":"@",1:$P(Y,U))
;
;
LOADCC(DGIOCC) ;load control code mnemonics array
; This function loads values from the CONTROL CODE (#2) subfield of
; the CONTROL CODES (#55) field of the TERMINAL TYPE (#3.2) file into
; an array subscripted by the CONTROL CODE ABBREVIATION (#.01) subfield
; value.
;
; Controlled Subscription DBIA: #3435 CONTROL CODES SUBFILE
;
; Input:
; DGIOCC - variable name to contain control codes array
;
; Output:
; Function value - 1 when control codes exist, 0 when no control
; codes exist
; DGIOCC - array of control codes
;
N DGI ;generic counter
N DGMNE ;control code abbreviation
;
S DGI=0
F S DGI=$O(^%ZIS(2,IOST(0),55,DGI)) Q:'DGI D
. S DGMNE=$P($G(^%ZIS(2,IOST(0),55,DGI,0)),U)
. I DGMNE]"" S DGIOCC(DGMNE)=^%ZIS(2,IOST(0),55,DGI,1)
;
Q $S('$D(DGIOCC):0,1:1)
;
BLDLNAR(DGDFN,DGLOC,DGTEXT) ;build array of text lines
;
; Input:
; DGDFN - pointer to patient in PATIENT (#2) file
; DGLOC - inpatient location flag
;
; Output:
; Function value - count of returned lines on success; 0 on failure
; DGTEXT - numeric subscripted array of label text lines
;
N DFN,VA,VADM,VAERR ;VADPT variables
N DGI ;line counter
;
S DGI=0
;
I +$G(DGDFN),$D(^DPT(DGDFN,0)) D
. S DFN=DGDFN
. D DEM^VADPT
. S DGI=DGI+1
. S DGTEXT(DGI)="Name: "_$G(VADM(1))
. S DGI=DGI+1
. S DGTEXT(DGI)=" SSN: "_$P($G(VADM(2)),U,2)
. S DGI=DGI+1
. S DGTEXT(DGI)=" DOB: "_$$FMTE^XLFDT($P($G(VADM(3)),U),"5Z")
. ;WARD LOCATION and ROOM-BED
. S DGI=DGI+1
. S DGTEXT(DGI)=$S(DGLOC:"Ward: "_$S($D(^DPT(DFN,.1)):^DPT(DFN,.1)_" "_$G(^DPT(DFN,.101)),1:"UNKNOWN"),1:"")
;
Q DGI
;
END ;cleanup and close device
I $D(ZTQUEUED) S ZTREQ="@"
E D ^%ZISC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPLBL 6409 printed Dec 13, 2024@02:49:03 Page 2
DGPLBL ;ALB/RPM - PATIENT INFORMATION LABELS ; 05/07/04
+1 ;;5.3;Registration;**571**;Aug 13, 1993
+2 ;
+3 ;This routine provides a generic patient demographics label
+4 ;print that includes Patient Name, SSN, DOB and an optional
+5 ;inpatient location (ward and bed). Support for various printer
+6 ;types (i.e. bar code, laser, etc.) is provided using the CONTROL
+7 ;CODES (#3.2055) subfile of the TERMINAL TYPE (#3.2) file. The
+8 ;control code mnemonics are documented in DBIA# 3435.
+9 ;
+10 ;no direct entry
QUIT
+11 ;
EN ;main entry point used by DG PRINT PATIENT LABEL option
+1 ;
+2 ;selected patients array
NEW DGDFNS
+3 ;control codes array
NEW DGIOCC
+4 ;label count
NEW DGLBCNT
+5 ;lines per label
NEW DGLPL
+6 ;include location flag (0 or 1)
NEW DGLOC
+7 ;queuing variables
NEW DGQVAR
+8 ;
+9 ;select list of patients to print
+10 if '$$SELPATS("DGDFNS")
QUIT
+11 ;
+12 SET DGLOC=$$ASK("Include Inpatient Location on Label","Y","YES","Answer YES to include the inpatient ward and bed location on the label")
+13 if (DGLOC<0)
QUIT
+14 ;
+15 SET DGLBCNT=$$ASK("Number of Labels per patient",1,"NO^1:250:0","Enter the number of labels to print per patient, from 1 to 250")
+16 if (DGLBCNT<0)
QUIT
+17 ;
+18 SET DGLPL=$$ASK("Number of Lines per Label",6,"NO^6:25:0","Enter the total number of lines that the label stock can contain (6-25)")
+19 if (DGLPL<0)
QUIT
+20 ;
+21 ;
+22 ;init queued variables and select output device
+23 SET DGQVAR("DGDFNS(")=""
+24 SET DGQVAR("DGLBCNT")=""
+25 SET DGQVAR("DGLPL")=""
+26 SET DGQVAR("DGLOC")=""
+27 DO EN^XUTMDEVQ("START^DGPLBL","DG PRINT PATIENT LABEL",.DGQVAR)
+28 QUIT
+29 ;
START ;retrieve label field data and print labels
+1 ;
+2 ; Input:
+3 ; DGDFNS - array subscripted by pointer to PATIENT (#2) file
+4 ; DGLBCNT - number of labels to print per patient
+5 ; DGLPL - number of lines per label
+6 ; DGLOC - print ward location flag
+7 ;
+8 ; Output:
+9 ; none
+10 ;
+11 ;pointer to PATIENT file
NEW DGDFN
+12 ;generic counters
NEW DGI,DGJ
+13 ;printer Control Codes
NEW DGIOCC
+14 ;line array index
NEW DGLN
+15 ;line count
NEW DGLNCNT
+16 ;line text
NEW DGLINE
+17 ;
+18 ;initialize printer
+19 SET DGIOCC=$$LOADCC(.DGIOCC)
+20 ;format initialize
IF DGIOCC
IF $GET(DGIOCC("FI"))]""
XECUTE DGIOCC("FI")
+21 ;
+22 ;for each patient
+23 SET DGDFN=0
+24 FOR
SET DGDFN=$ORDER(DGDFNS(DGDFN))
if 'DGDFN
QUIT
Begin DoDot:1
+25 ;
+26 ;build text line array
+27 SET DGLNCNT=$$BLDLNAR(DGDFN,DGLOC,.DGLINE)
+28 if 'DGLNCNT
QUIT
+29 ;
+30 ;print patient's labels
+31 FOR DGI=1:1:DGLBCNT
Begin DoDot:2
+32 ;start of label
IF DGIOCC
IF $GET(DGIOCC("SL"))]""
XECUTE DGIOCC("SL")
+33 ;for each line
+34 FOR DGLN=1:1:DGLNCNT
Begin DoDot:3
+35 ;start text
IF DGIOCC
IF $GET(DGIOCC("ST"))]""
XECUTE DGIOCC("ST")
+36 ;start text field
IF DGIOCC
IF $GET(DGIOCC("STF"))]""
XECUTE DGIOCC("STF")
+37 WRITE $GET(DGLINE(DGLN))
+38 ;end text field
IF DGIOCC
IF $GET(DGIOCC("ETF"))]""
XECUTE DGIOCC("ETF")
+39 ;end text
IF DGIOCC
IF $GET(DGIOCC("ET"))]""
XECUTE DGIOCC("ET")
+40 IF 'DGIOCC
WRITE !
End DoDot:3
+41 ;end of label
IF DGIOCC
IF $GET(DGIOCC("EL"))]""
XECUTE DGIOCC("EL")
+42 IF 'DGIOCC
IF DGLNCNT<DGLPL
FOR DGJ=1:1:(DGLPL-DGLNCNT)
WRITE !
End DoDot:2
End DoDot:1
+43 ;format end
IF DGIOCC
IF $GET(DGIOCC("FE"))]""
XECUTE DGIOCC("FE")
+44 ;
+45 DO END
+46 ;
+47 QUIT
+48 ;
SELPATS(DGARR) ;select patient(s) to print
+1 ;
+2 ; Input:
+3 ; DGARR - array name to contain returned patients
+4 ;
+5 ; Output:
+6 ; Function value - 1 on success; 0 on failure
+7 ; DGARR - array of returned patients on success
+8 ;
+9 ;FM file reference
NEW DIC
+10 ;contains name of subscripted variable to return
NEW VAUTVB
+11 ;define to prevent "ALL" option
NEW VAUTNALL
+12 ;prompt string following "Select "
NEW VAUTSTR
+13 ;sort type flag [1:alpha if .01 not pointer,2:numeric,
NEW VAUTNI
+14 ; 3:alpha]
+15 ;
+16 SET DIC="^DPT("
SET VAUTVB=DGARR
SET VAUTNALL=1
SET VAUTNI=2
SET VAUTSTR="PATIENT"
+17 DO FIRST^VAUTOMA
+18 QUIT $SELECT($ORDER(@DGARR@("")):1,1:0)
+19 ;
+20 ;
ASK(DGDIRA,DGDIRB,DGDIR0,DGDIRH) ;
+1 ; Input
+2 ; DGDIR0 - DIR(0) string
+3 ; DGDIRA - DIR("A") string
+4 ; DGDIRB - DIR("B") string
+5 ; DGDIRH - DIR("?") string
+6 ;
+7 ; Output
+8 ; Function Value - Internal value returned from ^DIR or -1 if user
+9 ; up-arrows, double up-arrows or the read times out.
+10 ;
+11 ; DIR(0) type Results
+12 ; ------------ -------------------------------
+13 ; DD IEN of selected entry
+14 ; Numeric Value of number entered by user
+15 ; Pointer IEN of selected entry
+16 ; Set of Codes Internal value of code
+17 ; Yes/No 0 for No, 1 for Yes
+18 ;
+19 ;^DIR variables
NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+20 ;
+21 SET DIR(0)=DGDIR0
+22 SET DIR("A")=$GET(DGDIRA)
+23 IF $GET(DGDIRB)]""
SET DIR("B")=DGDIRB
+24 IF $GET(DGDIRH)]""
SET DIR("?")=DGDIRH
+25 DO ^DIR
+26 QUIT $SELECT($DATA(DUOUT):-1,$DATA(DTOUT):-1,$DATA(DIROUT):-1,X="@":"@",1:$PIECE(Y,U))
+27 ;
+28 ;
LOADCC(DGIOCC) ;load control code mnemonics array
+1 ; This function loads values from the CONTROL CODE (#2) subfield of
+2 ; the CONTROL CODES (#55) field of the TERMINAL TYPE (#3.2) file into
+3 ; an array subscripted by the CONTROL CODE ABBREVIATION (#.01) subfield
+4 ; value.
+5 ;
+6 ; Controlled Subscription DBIA: #3435 CONTROL CODES SUBFILE
+7 ;
+8 ; Input:
+9 ; DGIOCC - variable name to contain control codes array
+10 ;
+11 ; Output:
+12 ; Function value - 1 when control codes exist, 0 when no control
+13 ; codes exist
+14 ; DGIOCC - array of control codes
+15 ;
+16 ;generic counter
NEW DGI
+17 ;control code abbreviation
NEW DGMNE
+18 ;
+19 SET DGI=0
+20 FOR
SET DGI=$ORDER(^%ZIS(2,IOST(0),55,DGI))
if 'DGI
QUIT
Begin DoDot:1
+21 SET DGMNE=$PIECE($GET(^%ZIS(2,IOST(0),55,DGI,0)),U)
+22 IF DGMNE]""
SET DGIOCC(DGMNE)=^%ZIS(2,IOST(0),55,DGI,1)
End DoDot:1
+23 ;
+24 QUIT $SELECT('$DATA(DGIOCC):0,1:1)
+25 ;
BLDLNAR(DGDFN,DGLOC,DGTEXT) ;build array of text lines
+1 ;
+2 ; Input:
+3 ; DGDFN - pointer to patient in PATIENT (#2) file
+4 ; DGLOC - inpatient location flag
+5 ;
+6 ; Output:
+7 ; Function value - count of returned lines on success; 0 on failure
+8 ; DGTEXT - numeric subscripted array of label text lines
+9 ;
+10 ;VADPT variables
NEW DFN,VA,VADM,VAERR
+11 ;line counter
NEW DGI
+12 ;
+13 SET DGI=0
+14 ;
+15 IF +$GET(DGDFN)
IF $DATA(^DPT(DGDFN,0))
Begin DoDot:1
+16 SET DFN=DGDFN
+17 DO DEM^VADPT
+18 SET DGI=DGI+1
+19 SET DGTEXT(DGI)="Name: "_$GET(VADM(1))
+20 SET DGI=DGI+1
+21 SET DGTEXT(DGI)=" SSN: "_$PIECE($GET(VADM(2)),U,2)
+22 SET DGI=DGI+1
+23 SET DGTEXT(DGI)=" DOB: "_$$FMTE^XLFDT($PIECE($GET(VADM(3)),U),"5Z")
+24 ;WARD LOCATION and ROOM-BED
+25 SET DGI=DGI+1
+26 SET DGTEXT(DGI)=$SELECT(DGLOC:"Ward: "_$SELECT($DATA(^DPT(DFN,.1)):^DPT(DFN,.1)_" "_$GET(^DPT(DFN,.101)),1:"UNKNOWN"),1:"")
End DoDot:1
+27 ;
+28 QUIT DGI
+29 ;
END ;cleanup and close device
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 IF '$TEST
DO ^%ZISC
+3 QUIT
