- DGPWBD ;ALB/CAW - Device Specifications for Patient Wristband ;2/14/95
- ;;5.3;Registration;**62,82,246,385,1004,1009,1015,1018**;MAY 28, 2004;Build 27
- ;IHS/OIT/LJF 11/04/2005 PATCH 1004 barcode will be facility code & chart #
- ;cmi/anch/maw 02/18/2008 PATCH 1009 requirement 3
- ;IHS/OIT/CLS 03/31/2015 PATCH 1018 added code at label ADD for BCMA print of wristbands
- ;
- BL ; Barcode Blazer
- N LINE
- I IOST["P-TCP-ZEBR WRISTB" G ADD
- U IO
- S LINE=$G(^%ZIS(2,IOST(0),203)) W LINE,LINE1,!
- S LINE=$G(^%ZIS(2,IOST(0),205)) W LINE,LINE2,!
- S LINE=$G(^%ZIS(2,IOST(0),207)) W LINE,LINE3,!
- S LINE=$G(^%ZIS(2,IOST(0),209)) W LINE,LINE4,!
- ;
- ;IHS/OIT/LJF 11/04/2005 PATCH 1004 using facility code_chart # (12 digits)
- ;S VARIABLE=$P(VADM(2),U)
- ;VARIABLE is the SSN without dashes.
- S VARIABLE=$$HRCNF^BDGF2(DFN,DUZ(2))
- ;
- I $L($G(^%ZIS(2,+IOST(0),"BAR1"))) W @^%ZIS(2,IOST(0),"BAR1")
- W VARIABLE ;cmi/maw 2/18/2008 PATCH 1009 requirement 3
- Q
- ADD ; Add different barcode set up here
- ;FOXK VAOIT 3-2013,1-2014
- N CPSIO,I,CPSPID1,CPSLINE,CPSPID
- ;PRINT 12 DIGIT HRCN ON LABEL.
- S CPSPID=0 ;DEFAULTS TO NO
- ;GET CONTROL CODE FROM TERMINAL TYPE
- S I=0 F S I=$O(^%ZIS(2,IOST(0),55,I)) Q:'I S X0=$G(^(I,0)) I X0]"" S CPSIO($P(X0,"^"))=^(1)
- S CPSIO=$S('$D(CPSIO):0,1:1)
- S CPSPID1=$S(DUZ("AG")="I":$$HRCNF^BDGF2(DFN,DUZ(2)),1:$$SSN^DPTLK1(DFN))
- U IO
- ;LINES ARE DEFINED IN ^DIC(39.1, FOR WRISTBAND ITEMS.
- F I="FI","SL" I $G(CPSIO(I))]"" X CPSIO(I)
- ;NAME
- F I="SLIN1","STF" I $G(CPSIO(I))]"" X CPSIO(I)
- W $E(LINE1,1,28) ;ONLY 28 LENGTH
- F I="ETF","ELIN1" I $G(CPSIO(I))]"" X CPSIO(I)
- W !
- ;HRCN
- I CPSPID=1 D
- .F I="SHR","STF" I $G(CPSIO(I))]"" X CPSIO(I)
- .W $S(DUZ("AG")="I":+$E(CPSPID1,7,$L(CPSPID1)),1:+CPSPID1) ;STRIP ASUFAC FOR IHS ONLY
- .F I="ETF","EHR" I $G(CPSIO(I))]"" X CPSIO(I)
- .W !
- ;DO LINES 2-4
- F NUM=2:1:4 D
- .F I="SLIN"_NUM,"STF" I $G(CPSIO(I))]"" X CPSIO(I)
- .S CPSLINE="LINE"_NUM W @CPSLINE
- .F I="ETF","ELIN"_NUM I $G(CPSIO(I))]"" X CPSIO(I)
- .W !
- ;INFANT ONLY MOTHERS NAME
- I $G(CPSMOM)=1 D
- .F I="SMOM","STF" I $G(CPSIO(I))]"" X CPSIO(I)
- .W "Mom:"_$$GET1^DIQ(9000001,DFN,2604.2)
- .F I="EMOM","ETF" I $G(CPSIO(I))]"" X CPSIO(I)
- .W !
- ;PRINTED DT
- F I="PTDT","STF" I $G(CPSIO(I))]"" X CPSIO(I)
- W "Printed: "_$E(DT,4,5),"/",$E(DT,6,7),"/",$E(DT,2,3)
- F I="ETF","EPTDT" I $G(CPSIO(I))]"" X CPSIO(I)
- W !
- ;BARCODE DATA MATRIX
- S:'+$G(DMCNT) DMCNT=1 ;DEFAULT TO 1 IF NOT SET
- F J=1:1:DMCNT D
- .F I="SBALL","SBF" I $G(CPSIO(I))]"" X CPSIO(I)
- .W CPSPID1
- .F I="EBF","EBALL" I $G(CPSIO(I))]"" X CPSIO(I)
- .W !
- F I="SB128","SBF" I $G(CPSIO(I))]"" X CPSIO(I)
- W $S(DUZ("AG")="I":+$E(CPSPID1,7,$L(CPSPID1)),1:+CPSPID1) ;STRIP ASUFAC FOR IHS ONLY
- F I="EBF","EB128" I $G(CPSIO(I))]"" X CPSIO(I)
- W !
- ;END LABEL
- F I="EL" I $G(CPSIO(I))]"" X CPSIO(I)
- W !
- D ^%ZISC
- Q
- DGPWBD ;ALB/CAW - Device Specifications for Patient Wristband ;2/14/95
- +1 ;;5.3;Registration;**62,82,246,385,1004,1009,1015,1018**;MAY 28, 2004;Build 27
- +2 ;IHS/OIT/LJF 11/04/2005 PATCH 1004 barcode will be facility code & chart #
- +3 ;cmi/anch/maw 02/18/2008 PATCH 1009 requirement 3
- +4 ;IHS/OIT/CLS 03/31/2015 PATCH 1018 added code at label ADD for BCMA print of wristbands
- +5 ;
- BL ; Barcode Blazer
- +1 NEW LINE
- +2 IF IOST["P-TCP-ZEBR WRISTB"
- GOTO ADD
- +3 USE IO
- +4 SET LINE=$GET(^%ZIS(2,IOST(0),203))
- WRITE LINE,LINE1,!
- +5 SET LINE=$GET(^%ZIS(2,IOST(0),205))
- WRITE LINE,LINE2,!
- +6 SET LINE=$GET(^%ZIS(2,IOST(0),207))
- WRITE LINE,LINE3,!
- +7 SET LINE=$GET(^%ZIS(2,IOST(0),209))
- WRITE LINE,LINE4,!
- +8 ;
- +9 ;IHS/OIT/LJF 11/04/2005 PATCH 1004 using facility code_chart # (12 digits)
- +10 ;S VARIABLE=$P(VADM(2),U)
- +11 ;VARIABLE is the SSN without dashes.
- +12 SET VARIABLE=$$HRCNF^BDGF2(DFN,DUZ(2))
- +13 ;
- +14 IF $LENGTH($GET(^%ZIS(2,+IOST(0),"BAR1")))
- WRITE @^%ZIS(2,IOST(0),"BAR1")
- +15 ;cmi/maw 2/18/2008 PATCH 1009 requirement 3
- WRITE VARIABLE
- +16 QUIT
- ADD ; Add different barcode set up here
- +1 ;FOXK VAOIT 3-2013,1-2014
- +2 NEW CPSIO,I,CPSPID1,CPSLINE,CPSPID
- +3 ;PRINT 12 DIGIT HRCN ON LABEL.
- +4 ;DEFAULTS TO NO
- SET CPSPID=0
- +5 ;GET CONTROL CODE FROM TERMINAL TYPE
- +6 SET I=0
- FOR
- SET I=$ORDER(^%ZIS(2,IOST(0),55,I))
- IF 'I
- QUIT
- SET X0=$GET(^(I,0))
- IF X0]""
- SET CPSIO($PIECE(X0,"^"))=^(1)
- +7 SET CPSIO=$SELECT('$DATA(CPSIO):0,1:1)
- +8 SET CPSPID1=$SELECT(DUZ("AG")="I":$$HRCNF^BDGF2(DFN,DUZ(2)),1:$$SSN^DPTLK1(DFN))
- +9 USE IO
- +10 ;LINES ARE DEFINED IN ^DIC(39.1, FOR WRISTBAND ITEMS.
- +11 FOR I="FI","SL"
- IF $GET(CPSIO(I))]""
- XECUTE CPSIO(I)
- +12 ;NAME
- +13 FOR I="SLIN1","STF"
- IF $GET(CPSIO(I))]""
- XECUTE CPSIO(I)
- +14 ;ONLY 28 LENGTH
- WRITE $EXTRACT(LINE1,1,28)
- +15 FOR I="ETF","ELIN1"
- IF $GET(CPSIO(I))]""
- XECUTE CPSIO(I)
- +16 WRITE !
- +17 ;HRCN
- +18 IF CPSPID=1
- Begin DoDot:1
- +19 FOR I="SHR","STF"
- IF $GET(CPSIO(I))]""
- XECUTE CPSIO(I)
- +20 ;STRIP ASUFAC FOR IHS ONLY
- WRITE $SELECT(DUZ("AG")="I":+$EXTRACT(CPSPID1,7,$LENGTH(CPSPID1)),1:+CPSPID1)
- +21 FOR I="ETF","EHR"
- IF $GET(CPSIO(I))]""
- XECUTE CPSIO(I)
- +22 WRITE !
- End DoDot:1
- +23 ;DO LINES 2-4
- +24 FOR NUM=2:1:4
- Begin DoDot:1
- +25 FOR I="SLIN"_NUM,"STF"
- IF $GET(CPSIO(I))]""
- XECUTE CPSIO(I)
- +26 SET CPSLINE="LINE"_NUM
- WRITE @CPSLINE
- +27 FOR I="ETF","ELIN"_NUM
- IF $GET(CPSIO(I))]""
- XECUTE CPSIO(I)
- +28 WRITE !
- End DoDot:1
- +29 ;INFANT ONLY MOTHERS NAME
- +30 IF $GET(CPSMOM)=1
- Begin DoDot:1
- +31 FOR I="SMOM","STF"
- IF $GET(CPSIO(I))]""
- XECUTE CPSIO(I)
- +32 WRITE "Mom:"_$$GET1^DIQ(9000001,DFN,2604.2)
- +33 FOR I="EMOM","ETF"
- IF $GET(CPSIO(I))]""
- XECUTE CPSIO(I)
- +34 WRITE !
- End DoDot:1
- +35 ;PRINTED DT
- +36 FOR I="PTDT","STF"
- IF $GET(CPSIO(I))]""
- XECUTE CPSIO(I)
- +37 WRITE "Printed: "_$EXTRACT(DT,4,5),"/",$EXTRACT(DT,6,7),"/",$EXTRACT(DT,2,3)
- +38 FOR I="ETF","EPTDT"
- IF $GET(CPSIO(I))]""
- XECUTE CPSIO(I)
- +39 WRITE !
- +40 ;BARCODE DATA MATRIX
- +41 ;DEFAULT TO 1 IF NOT SET
- IF '+$GET(DMCNT)
- SET DMCNT=1
- +42 FOR J=1:1:DMCNT
- Begin DoDot:1
- +43 FOR I="SBALL","SBF"
- IF $GET(CPSIO(I))]""
- XECUTE CPSIO(I)
- +44 WRITE CPSPID1
- +45 FOR I="EBF","EBALL"
- IF $GET(CPSIO(I))]""
- XECUTE CPSIO(I)
- +46 WRITE !
- End DoDot:1
- +47 FOR I="SB128","SBF"
- IF $GET(CPSIO(I))]""
- XECUTE CPSIO(I)
- +48 ;STRIP ASUFAC FOR IHS ONLY
- WRITE $SELECT(DUZ("AG")="I":+$EXTRACT(CPSPID1,7,$LENGTH(CPSPID1)),1:+CPSPID1)
- +49 FOR I="EBF","EB128"
- IF $GET(CPSIO(I))]""
- XECUTE CPSIO(I)
- +50 WRITE !
- +51 ;END LABEL
- +52 FOR I="EL"
- IF $GET(CPSIO(I))]""
- XECUTE CPSIO(I)
- +53 WRITE !
- +54 DO ^%ZISC
- +55 QUIT
