- 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 Feb 19, 2025@00:15:05 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