DGPWB ;ALB/CAW/MLR - Patient Wristband Print ; 9/27/00 3:40pm
;;5.3;Registration;**62,82,287**;Aug 13, 1993
; -**287** Substituting SS# when Primary long ID missing in .36
;
EN ; Ask patient name
; This is used when printing a wristband from the menu
;
N DFN,VAIN,VAERR,DIC,Y,OPTIND
S OPTIND=0
S DIC(0)="AEMQZ",DIC="^DPT("
D ^DIC I $D(DTOUT)!$D(DUOUT)!(Y<0) G ENQ
S DFN=+Y D INP^VADPT
S:'$G(VAIN(4)) OPTIND=1
I $G(VAIN(4)),('$$DIVISION($P(VAIN(4),U))) W !,"Printing Wristbands for inpatients at this division is set to no." G ENQ
I OPTIND S Y=$$DEVICE() G:'Y!(Y>1) ENQ D SET G ENQ
D START(DFN)
ENQ K DTOUT,DUOUT Q
;
START(DFN) ;Start
; This is where it will be used when in admit or transfer
; Input is patient IFN
;
N WARD,DIVISION,PRINT,Y
D INP^VADPT I '$G(VAIN(4)) G STARTQ
S WARD=+VAIN(4)
TRANS I $G(DGPMA),'$$TRCHK($P(DGPMA,U,18)) G STARTQ
; Check to see if no change was made on edit
I $D(DGPMA),$D(DGPMP),$P(DGPMA,U,18)=41 N Y D G DIV:Y
.S Y=$O(^UTILITY("DGPM",$J,2,"")) Q:'Y
.I $P(^UTILITY("DGPM",$J,2,Y,"P"),U,6)=$P(^UTILITY("DGPM",$J,2,Y,"A"),U,6) S Y=0
I $D(DGPMA),$D(DGPMP),($P(DGPMA,U,6)=$P(DGPMP,U,6)) G STARTQ
; Check to see if division parameter to print wristband is on
DIV I '$$DIVISION(WARD) G STARTQ
I $G(DGPMA),'$$ASK G STARTQ
; Prompt for device - quit if device is not selected or is queued
S Y=$$DEVICE() I 'Y!(Y>1) G STARTQ
; Set up lines to print
D SET
STARTQ Q
;
DIVISION(WARD) ; Obtain Divison from Ward Location
;
N Y,DIVISION
S Y=0
; Print Patient Wristband parameter
S DIVISION=$P($G(^DIC(42,+WARD,0)),U,11)
I '$P(^DG(43,1,"GL"),U,2) S DIVISION=$O(^DG(40.8,0))
I $P($G(^DG(40.8,+DIVISION,0)),U,8)="Y" S Y=1
Q Y
;
SET ;Set the lines to print
;This is where taskman will start when job is queued.
; Input needed is DFN and WARD (WARD is set to IFN of WARD LOCATION)
;
N CNT,BAND,DATA,FINAL,IFN,ITEMD,LINE,X,WHERE
D DEM^VADPT
;
; If a different wristband is going to be used-change name in "B" x-ref
;
S LINE=0 S IFN=$O(^DIC(39.1,"B","WRISTBAND",0)) Q:'IFN
F S LINE=$O(^DIC(39.1,IFN,1,LINE)) Q:'LINE D
.S DATA=0 F S DATA=$O(^DIC(39.1,IFN,1,LINE,1,DATA)) Q:'DATA D
..S ITEMD=^DIC(39.1,IFN,1,LINE,1,DATA,0)
..S X=$G(^DIC(39.2,+ITEMD,1)) X X
..;
..;Checking for PID# and substituting SS# if missing **287**
..I Y="",$G(^DIC(39.2,+ITEMD,0))="PID" D PID
..;
..S BAND(LINE,-DATA)=$E(Y,1,$P(ITEMD,U,3))_"^"_$P(ITEMD,U,2)
.S WHERE="" F S WHERE=$O(BAND(LINE,WHERE)) Q:'WHERE D
..I $D(BAND(LINE,(WHERE+1))) S $P(BAND(LINE,WHERE),U,2)=($P(BAND(LINE,WHERE),U,2))-($L($P(BAND(LINE,(WHERE+1)),U)))
..S $P(FINAL(LINE)," ",$P(BAND(LINE,WHERE),U,2))=$P(BAND(LINE,WHERE),U)
F CNT=1:1:99 Q:'$D(FINAL(CNT)) S X="LINE"_CNT S @X=FINAL(CNT)
D PRINT
D:'$D(ZTQUEUED) ^%ZISC
; This is where the call to update the allergy file
S X="GMRAMCU0" X ^%ZOSF("TEST") I $T D IDBAND^GMRAMCU0(DFN,DT,DUZ)
D END
Q
;
PID ;Substituting SS# for missing PID# **287** MLR
S Y=$P($G(^DPT(DFN,0)),U,9)
D
. I Y S Y=$E(Y,1,3)_" "_$E(Y,4,5)_" "_$E(Y,6,$L(Y)) Q
. S Y="NO ID FOUND" Q
Q ;PID
;
END ;Clean up variables
K VARIABLE
N CNT,VAR
F CNT=1:1:99 S VAR="LINE"_CNT Q:'$D(@VAR) K @VAR
Q
;
PRINT ; Print the wristband
;
; Change call from BL to whatever device is added in DGPWBD
;
D BL^DGPWBD
Q
;
DEVICE() ;
S Y=0
DEVEN S %ZIS="Q",%ZIS("A")="PRINT WRISTBAND ON DEVICE: ",%ZIS("B")=""
D ^%ZIS I POP G DEVICEQ
I $E(IOST,1,2)'["P-" W !,"A printer must be selected." G DEVEN
I '$D(IO("Q")) S Y=1 G DEVICEQ
S Y=$$QUE
DEVICEQ Q Y
;
QUE() ; -- que job
; return: did job que [ 1|yes 0|no ]
;
K ZTSK,IO("Q")
S ZTDESC="Patient Wristband Print",ZTRTN="SET^DGPWB"
F X="WARD","DFN" S ZTSAVE(X)=""
D ^%ZTLOAD W:$D(ZTSK) " (Task: ",ZTSK,")"
Q $D(ZTSK)
;
TRCHK(TYPE) ;Check to see if appropriate type to continue
;
N MVMT,Y
S Y=0
S MVMT=$P($G(^DG(405.2,+TYPE,0)),U,2) I MVMT=1 S Y=1 G TRCHKQ
I "^4^13^14^22^23^24^41^44^45^"[(U_TYPE_U) S Y=1
TRCHKQ Q Y
;
ASK() ;Ask if they want to print
W ! S DIR("A")="Do you want to print a Patient Wristband"
S DIR(0)="Y",DIR("B")="YES"
D ^DIR K DIR I $D(DUOUT)!($D(DTOUT)) S Y=0
ASKQ Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPWB 4252 printed Oct 16, 2024@18:55:05 Page 2
DGPWB ;ALB/CAW/MLR - Patient Wristband Print ; 9/27/00 3:40pm
+1 ;;5.3;Registration;**62,82,287**;Aug 13, 1993
+2 ; -**287** Substituting SS# when Primary long ID missing in .36
+3 ;
EN ; Ask patient name
+1 ; This is used when printing a wristband from the menu
+2 ;
+3 NEW DFN,VAIN,VAERR,DIC,Y,OPTIND
+4 SET OPTIND=0
+5 SET DIC(0)="AEMQZ"
SET DIC="^DPT("
+6 DO ^DIC
IF $DATA(DTOUT)!$DATA(DUOUT)!(Y<0)
GOTO ENQ
+7 SET DFN=+Y
DO INP^VADPT
+8 if '$GET(VAIN(4))
SET OPTIND=1
+9 IF $GET(VAIN(4))
IF ('$$DIVISION($PIECE(VAIN(4),U)))
WRITE !,"Printing Wristbands for inpatients at this division is set to no."
GOTO ENQ
+10 IF OPTIND
SET Y=$$DEVICE()
if 'Y!(Y>1)
GOTO ENQ
DO SET
GOTO ENQ
+11 DO START(DFN)
ENQ KILL DTOUT,DUOUT
QUIT
+1 ;
START(DFN) ;Start
+1 ; This is where it will be used when in admit or transfer
+2 ; Input is patient IFN
+3 ;
+4 NEW WARD,DIVISION,PRINT,Y
+5 DO INP^VADPT
IF '$GET(VAIN(4))
GOTO STARTQ
+6 SET WARD=+VAIN(4)
TRANS IF $GET(DGPMA)
IF '$$TRCHK($PIECE(DGPMA,U,18))
GOTO STARTQ
+1 ; Check to see if no change was made on edit
+2 IF $DATA(DGPMA)
IF $DATA(DGPMP)
IF $PIECE(DGPMA,U,18)=41
NEW Y
Begin DoDot:1
+3 SET Y=$ORDER(^UTILITY("DGPM",$JOB,2,""))
if 'Y
QUIT
+4 IF $PIECE(^UTILITY("DGPM",$JOB,2,Y,"P"),U,6)=$PIECE(^UTILITY("DGPM",$JOB,2,Y,"A"),U,6)
SET Y=0
End DoDot:1
if Y
GOTO DIV
+5 IF $DATA(DGPMA)
IF $DATA(DGPMP)
IF ($PIECE(DGPMA,U,6)=$PIECE(DGPMP,U,6))
GOTO STARTQ
+6 ; Check to see if division parameter to print wristband is on
DIV IF '$$DIVISION(WARD)
GOTO STARTQ
+1 IF $GET(DGPMA)
IF '$$ASK
GOTO STARTQ
+2 ; Prompt for device - quit if device is not selected or is queued
+3 SET Y=$$DEVICE()
IF 'Y!(Y>1)
GOTO STARTQ
+4 ; Set up lines to print
+5 DO SET
STARTQ QUIT
+1 ;
DIVISION(WARD) ; Obtain Divison from Ward Location
+1 ;
+2 NEW Y,DIVISION
+3 SET Y=0
+4 ; Print Patient Wristband parameter
+5 SET DIVISION=$PIECE($GET(^DIC(42,+WARD,0)),U,11)
+6 IF '$PIECE(^DG(43,1,"GL"),U,2)
SET DIVISION=$ORDER(^DG(40.8,0))
+7 IF $PIECE($GET(^DG(40.8,+DIVISION,0)),U,8)="Y"
SET Y=1
+8 QUIT Y
+9 ;
SET ;Set the lines to print
+1 ;This is where taskman will start when job is queued.
+2 ; Input needed is DFN and WARD (WARD is set to IFN of WARD LOCATION)
+3 ;
+4 NEW CNT,BAND,DATA,FINAL,IFN,ITEMD,LINE,X,WHERE
+5 DO DEM^VADPT
+6 ;
+7 ; If a different wristband is going to be used-change name in "B" x-ref
+8 ;
+9 SET LINE=0
SET IFN=$ORDER(^DIC(39.1,"B","WRISTBAND",0))
if 'IFN
QUIT
+10 FOR
SET LINE=$ORDER(^DIC(39.1,IFN,1,LINE))
if 'LINE
QUIT
Begin DoDot:1
+11 SET DATA=0
FOR
SET DATA=$ORDER(^DIC(39.1,IFN,1,LINE,1,DATA))
if 'DATA
QUIT
Begin DoDot:2
+12 SET ITEMD=^DIC(39.1,IFN,1,LINE,1,DATA,0)
+13 SET X=$GET(^DIC(39.2,+ITEMD,1))
XECUTE X
+14 ;
+15 ;Checking for PID# and substituting SS# if missing **287**
+16 IF Y=""
IF $GET(^DIC(39.2,+ITEMD,0))="PID"
DO PID
+17 ;
+18 SET BAND(LINE,-DATA)=$EXTRACT(Y,1,$PIECE(ITEMD,U,3))_"^"_$PIECE(ITEMD,U,2)
End DoDot:2
+19 SET WHERE=""
FOR
SET WHERE=$ORDER(BAND(LINE,WHERE))
if 'WHERE
QUIT
Begin DoDot:2
+20 IF $DATA(BAND(LINE,(WHERE+1)))
SET $PIECE(BAND(LINE,WHERE),U,2)=($PIECE(BAND(LINE,WHERE),U,2))-($LENGTH($PIECE(BAND(LINE,(WHERE+1)),U)))
+21 SET $PIECE(FINAL(LINE)," ",$PIECE(BAND(LINE,WHERE),U,2))=$PIECE(BAND(LINE,WHERE),U)
End DoDot:2
End DoDot:1
+22 FOR CNT=1:1:99
if '$DATA(FINAL(CNT))
QUIT
SET X="LINE"_CNT
SET @X=FINAL(CNT)
+23 DO PRINT
+24 if '$DATA(ZTQUEUED)
DO ^%ZISC
+25 ; This is where the call to update the allergy file
+26 SET X="GMRAMCU0"
XECUTE ^%ZOSF("TEST")
IF $TEST
DO IDBAND^GMRAMCU0(DFN,DT,DUZ)
+27 DO END
+28 QUIT
+29 ;
PID ;Substituting SS# for missing PID# **287** MLR
+1 SET Y=$PIECE($GET(^DPT(DFN,0)),U,9)
+2 Begin DoDot:1
+3 IF Y
SET Y=$EXTRACT(Y,1,3)_" "_$EXTRACT(Y,4,5)_" "_$EXTRACT(Y,6,$LENGTH(Y))
QUIT
+4 SET Y="NO ID FOUND"
QUIT
End DoDot:1
+5 ;PID
QUIT
+6 ;
END ;Clean up variables
+1 KILL VARIABLE
+2 NEW CNT,VAR
+3 FOR CNT=1:1:99
SET VAR="LINE"_CNT
if '$DATA(@VAR)
QUIT
KILL @VAR
+4 QUIT
+5 ;
PRINT ; Print the wristband
+1 ;
+2 ; Change call from BL to whatever device is added in DGPWBD
+3 ;
+4 DO BL^DGPWBD
+5 QUIT
+6 ;
DEVICE() ;
+1 SET Y=0
DEVEN SET %ZIS="Q"
SET %ZIS("A")="PRINT WRISTBAND ON DEVICE: "
SET %ZIS("B")=""
+1 DO ^%ZIS
IF POP
GOTO DEVICEQ
+2 IF $EXTRACT(IOST,1,2)'["P-"
WRITE !,"A printer must be selected."
GOTO DEVEN
+3 IF '$DATA(IO("Q"))
SET Y=1
GOTO DEVICEQ
+4 SET Y=$$QUE
DEVICEQ QUIT Y
+1 ;
QUE() ; -- que job
+1 ; return: did job que [ 1|yes 0|no ]
+2 ;
+3 KILL ZTSK,IO("Q")
+4 SET ZTDESC="Patient Wristband Print"
SET ZTRTN="SET^DGPWB"
+5 FOR X="WARD","DFN"
SET ZTSAVE(X)=""
+6 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE " (Task: ",ZTSK,")"
+7 QUIT $DATA(ZTSK)
+8 ;
TRCHK(TYPE) ;Check to see if appropriate type to continue
+1 ;
+2 NEW MVMT,Y
+3 SET Y=0
+4 SET MVMT=$PIECE($GET(^DG(405.2,+TYPE,0)),U,2)
IF MVMT=1
SET Y=1
GOTO TRCHKQ
+5 IF "^4^13^14^22^23^24^41^44^45^"[(U_TYPE_U)
SET Y=1
TRCHKQ QUIT Y
+1 ;
ASK() ;Ask if they want to print
+1 WRITE !
SET DIR("A")="Do you want to print a Patient Wristband"
+2 SET DIR(0)="Y"
SET DIR("B")="YES"
+3 DO ^DIR
KILL DIR
IF $DATA(DUOUT)!($DATA(DTOUT))
SET Y=0
ASKQ QUIT Y
