- BLRLABLA ; IHS/DIR/MKK - INTERMEC 4100 2 LABEL PRINT BARCODE/PLAIN 10:16 ;
- ;;5.2;LR;**1001,1006,1007,1009,1018,1019**;MAR 25, 2005
- ;;5.2;LR;**1001,1006,1007,1009**;Mar 7, 2001
- ;;5.2;LAB SERVICE;;Sep 27, 1994
- ;;V5.1;LAB;;04/11/91 11:06
- ;This routine is used in conjunction with the Intermec program routine
- ;LRBARA to print a two label accession label for accession areas which
- ;have their BAR CODE PRINT field set to YES
- ;LRLABELA may have to be renamed LRLABEL6
- ;The code S X=0 X ^%ZOSF("RM") is needed to replace the U IO:0 which
- ;works with MSM but not DSM
- ;
- EN S:$D(ZTQUEUED) ZTREQ="@"
- N I1,J
- S X=0 X ^%ZOSF("RM")
- S:'$L($G(LRRB)) LRRB=""
- S BLRURG="" ;IHS/DIR TUC/AAB 03/23/98
- S J=0,LRTXT="",FLAG=0 F I1=1:1 S J=$O(LRTS(J)) Q:J<1 I ($L(LRTXT)+$L(LRTS(J))'>24) S LRTXT=LRTXT_LRTS(J) S:$O(LRTS(J))>0 FLAG=1,LRTXT=LRTXT_";"
- FLAG S:FLAG=0 LRDTXT=LRTXT S:FLAG=1 LRDTXT=".............."
- S LRLPNM=$P(PNM,",",1),LRLPNM=LRLPNM_$S($L(LRLPNM)<18:","_$E($P(PNM,",",2),1),1:"")
- I $D(LRBAR) D BAR Q ;IHS/MJL 3/18/99
- D PRT K BLRURG
- ;Q:'$D(LRBAR)!('$D(LRBAR($G(LRAA))))
- Q ;IHS/DIR TUC/AAB 03/23/98
- ;
- BAR ;barcode label..accession number barcoded
- ;
- ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018 IHS/ITSC/MKK
- ; Make certain DOB has something in it
- NEW DOBSTR ; Date Of Birth STRing
- S DOBSTR=" DoB:"
- I $G(DOB)'="" D ; If DoB exists, get
- . S X=DOB S %DT="" D ^%DT
- . S DOBSTR=" DoB:"_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_($E(Y,1,3)+1700)
- ;
- ; Make certain date string has a 2-digit year
- NEW LRDSHRT ; LaboRatory SHort date
- S LRDSHRT=LRDAT
- I $L($P($P(LRDAT,"/",3)," ",1))>2 D
- . S LRDSHRT=$P(LRDAT,"/",1,2)_"/"_$E($P(LRDAT,"/",3),3,$L(LRDAT))
- ;
- ; Get Provider Name from NEW PERSON file, if it exists
- NEW PROVN ; Provider Name
- S PROVN="" ; Initialize
- NEW PTR ; Provider Pointer
- I $G(LRAA)'=""&($G(LRAD)'="")&($G(LRAN)'="") D
- . S PTR=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",8)
- . I $G(PTR)'="" S PROVN=$P($G(^VA(200,PTR,0)),"^",1)
- ;
- ; Location variable
- NEW LOCVAR ; Location String
- S LOCVAR="W:"_$E($G(LRLLOC),1,7)
- I $G(LRRB)'="" S LOCVAR=LOCVAR_" B:"_LRRB ; If Bed variable exists, get it
- ;
- NEW TESTSVAR ; TEST(S) VARiable
- S TESTSVAR=$E($G(LRTXT),1,32)
- I $L($G(LRTXT))>31 S TESTSVAR=TESTSVAR_"..."
- ;
- ; Urgency variable
- S BLRURG="" ; Intialize
- S LRURG0=$G(LRURG0) I LRURG0'="" S BLRURG=$E($P(^LAB(62.05,LRURG0,0),U,1),1,4) ;IHS/DIR TUC/AAB 03/23/98
- ;
- W *2,"R",*3
- W *2,*27,"E3",*24,!,TESTSVAR,*3 ; (01) Test(s)
- W *2,!,LRTOP,*3 ; (02) Collection sample - tube top/specimen
- W *2,!,"Order#:",LRCE,*3 ; (03) Order Number
- W *2,!,LRACC,*3 ; (04) Accession String
- W *2,!,LRDSHRT,*3 ; (05) Date
- W *2,!,HRCN,*3 ; (06) Health Record Number
- W *2,!,LOCVAR,*3 ; (07) Location
- W *2,!,$E(PNM,1,27),*3 ; (08) Patient Name
- W *2,!,BLRURG,*3 ; (09) Urgency
- W *2,!,$E("0000",$L(LRAN),4)_LRAN,*3 ; (10) Accession Number -- Bar Coded
- W *2,*23,*15,"S30",*12,*3
- ;
- K BLRURG ;IHS/DIR TUC/AAB 03/23/98
- ;----- END IHS MODIFICATIONS LR*5.2*1018 IHS/ITSC/MKK
- Q
- PRT ;plain label..no barcode
- ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018 IHS/ITSC/MKK
- ; Make certain DOB has something in it
- NEW DOBSTR ; Date Of Birth STRing
- S DOBSTR="XX/XX/XX" ; Initialize to nonsense
- I $G(DOB)'="" D ; If something there, set to real date
- . S X=$G(DOB)
- . S %DT=""
- . D ^%DT
- . S DOBSTR=" DoB:"_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_($E(Y,1,3)+1700)
- ;
- ; Make certain date string has a 2-digit year
- NEW LRDSHRT ; LaboRatory SHort date
- S LRDSHRT=LRDAT ; Initialize
- I $L($P($P(LRDAT,"/",3)," ",1))>2 D
- . S LRDSHRT=$P(LRDAT,"/",1,2)_"/"_$E($P(LRDAT,"/",3),3,$L(LRDAT))
- ;
- ; Make certain provider name has data
- NEW PROVN ; Provider Name
- S PROVN="" ; Initialize
- NEW PTR ; Provider Pointer
- I $G(LRAA)'=""&($G(LRAD)'="")&($G(LRAN)'="") D
- . S PTR=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",8)
- . I $G(PTR)'="" S PROVN=$P($G(^VA(200,PTR,0)),"^",1)
- ;
- ; Location variable
- NEW LOCVAR ; LOCation VARiable
- S LOCVAR="W:"_$E(LRLLOC,1,7)
- I $L(LRRB)>0 S LOCVAR=LOCVAR_" B:"_LRRB ; If Bed variable exists, get it
- ;
- NEW TESTSVAR ; TEST(S) VARiable
- S TESTSVAR=$E(LRTXT,1,32)
- I $L(LRTXT)>31 S TESTSVAR=TESTSVAR_"..."
- ;
- ; Urgency variable
- S BLRURG="" ; Initialize
- S LRURG0=$G(LRURG0) I LRURG0'="" S BLRURG=$E($P(^LAB(62.05,LRURG0,0),U,1),1,4) ;IHS/DIR TUC/AAB 03/23/98
- ;
- ;----- BEGIN IHS MODIFICATIONS LR*5.2*1019 IHS/ITSC/MKK
- ; Using $G in case any of the variables are null -- an issue with testing labels
- W *2,"R",*3
- W *2,*27,"E2",*24,!,$G(TESTSVAR),*3 ; Test(s)
- W *2,!,$G(LRTOP),*3 ; Collection sample - tube top/specimen
- W *2,!,"Order#:",$G(LRCE),*3 ; Order Number
- W *2,!,$G(LRACC),*3 ; Accession string
- W *2,!,$G(LRDSHRT),*3 ; Date
- W *2,!,$G(HRCN),*3 ; Health Record Number
- W *2,!,$G(LOCVAR),*3 ; Location
- W *2,!,$G(PNM),*3 ; Patient Name
- W *2,!,$G(BLRURG),*3 ; Urgency
- W *2,!,"Sex:",$G(SEX),*3 ; Sex
- W *2,!,"Prov:"_$E($G(PROVN),1,18),*3 ; Provider
- W *2,!,$G(DOBSTR),*3 ; Date of Birth
- ;----- END IHS MODIFICATIONS LR*5.2*1019 IHS/ITSC/MKK
- ;
- W *2,*23,*15,"S30",*12,*3
- ;----- END IHS MODIFICATIONS LR*5.2*1018 IHS/ITSC/MKK
- Q
- BLRLABLA ; IHS/DIR/MKK - INTERMEC 4100 2 LABEL PRINT BARCODE/PLAIN 10:16 ;
- +1 ;;5.2;LR;**1001,1006,1007,1009,1018,1019**;MAR 25, 2005
- +2 ;;5.2;LR;**1001,1006,1007,1009**;Mar 7, 2001
- +3 ;;5.2;LAB SERVICE;;Sep 27, 1994
- +4 ;;V5.1;LAB;;04/11/91 11:06
- +5 ;This routine is used in conjunction with the Intermec program routine
- +6 ;LRBARA to print a two label accession label for accession areas which
- +7 ;have their BAR CODE PRINT field set to YES
- +8 ;LRLABELA may have to be renamed LRLABEL6
- +9 ;The code S X=0 X ^%ZOSF("RM") is needed to replace the U IO:0 which
- +10 ;works with MSM but not DSM
- +11 ;
- EN IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +1 NEW I1,J
- +2 SET X=0
- XECUTE ^%ZOSF("RM")
- +3 IF '$LENGTH($GET(LRRB))
- SET LRRB=""
- +4 ;IHS/DIR TUC/AAB 03/23/98
- SET BLRURG=""
- +5 SET J=0
- SET LRTXT=""
- SET FLAG=0
- FOR I1=1:1
- SET J=$ORDER(LRTS(J))
- IF J<1
- QUIT
- IF ($LENGTH(LRTXT)+$LENGTH(LRTS(J))'>24)
- SET LRTXT=LRTXT_LRTS(J)
- IF $ORDER(LRTS(J))>0
- SET FLAG=1
- SET LRTXT=LRTXT_";"
- FLAG IF FLAG=0
- SET LRDTXT=LRTXT
- IF FLAG=1
- SET LRDTXT=".............."
- +1 SET LRLPNM=$PIECE(PNM,",",1)
- SET LRLPNM=LRLPNM_$SELECT($LENGTH(LRLPNM)<18:","_$EXTRACT($PIECE(PNM,",",2),1),1:"")
- +2 ;IHS/MJL 3/18/99
- IF $DATA(LRBAR)
- DO BAR
- QUIT
- +3 DO PRT
- KILL BLRURG
- +4 ;Q:'$D(LRBAR)!('$D(LRBAR($G(LRAA))))
- +5 ;IHS/DIR TUC/AAB 03/23/98
- QUIT
- +6 ;
- BAR ;barcode label..accession number barcoded
- +1 ;
- +2 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018 IHS/ITSC/MKK
- +3 ; Make certain DOB has something in it
- +4 ; Date Of Birth STRing
- NEW DOBSTR
- +5 SET DOBSTR=" DoB:"
- +6 ; If DoB exists, get
- IF $GET(DOB)'=""
- Begin DoDot:1
- +7 SET X=DOB
- SET %DT=""
- DO ^%DT
- +8 SET DOBSTR=" DoB:"_$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_($EXTRACT(Y,1,3)+1700)
- End DoDot:1
- +9 ;
- +10 ; Make certain date string has a 2-digit year
- +11 ; LaboRatory SHort date
- NEW LRDSHRT
- +12 SET LRDSHRT=LRDAT
- +13 IF $LENGTH($PIECE($PIECE(LRDAT,"/",3)," ",1))>2
- Begin DoDot:1
- +14 SET LRDSHRT=$PIECE(LRDAT,"/",1,2)_"/"_$EXTRACT($PIECE(LRDAT,"/",3),3,$LENGTH(LRDAT))
- End DoDot:1
- +15 ;
- +16 ; Get Provider Name from NEW PERSON file, if it exists
- +17 ; Provider Name
- NEW PROVN
- +18 ; Initialize
- SET PROVN=""
- +19 ; Provider Pointer
- NEW PTR
- +20 IF $GET(LRAA)'=""&($GET(LRAD)'="")&($GET(LRAN)'="")
- Begin DoDot:1
- +21 SET PTR=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",8)
- +22 IF $GET(PTR)'=""
- SET PROVN=$PIECE($GET(^VA(200,PTR,0)),"^",1)
- End DoDot:1
- +23 ;
- +24 ; Location variable
- +25 ; Location String
- NEW LOCVAR
- +26 SET LOCVAR="W:"_$EXTRACT($GET(LRLLOC),1,7)
- +27 ; If Bed variable exists, get it
- IF $GET(LRRB)'=""
- SET LOCVAR=LOCVAR_" B:"_LRRB
- +28 ;
- +29 ; TEST(S) VARiable
- NEW TESTSVAR
- +30 SET TESTSVAR=$EXTRACT($GET(LRTXT),1,32)
- +31 IF $LENGTH($GET(LRTXT))>31
- SET TESTSVAR=TESTSVAR_"..."
- +32 ;
- +33 ; Urgency variable
- +34 ; Intialize
- SET BLRURG=""
- +35 ;IHS/DIR TUC/AAB 03/23/98
- SET LRURG0=$GET(LRURG0)
- IF LRURG0'=""
- SET BLRURG=$EXTRACT($PIECE(^LAB(62.05,LRURG0,0),U,1),1,4)
- +36 ;
- +37 WRITE *2,"R",*3
- +38 ; (01) Test(s)
- WRITE *2,*27,"E3",*24,!,TESTSVAR,*3
- +39 ; (02) Collection sample - tube top/specimen
- WRITE *2,!,LRTOP,*3
- +40 ; (03) Order Number
- WRITE *2,!,"Order#:",LRCE,*3
- +41 ; (04) Accession String
- WRITE *2,!,LRACC,*3
- +42 ; (05) Date
- WRITE *2,!,LRDSHRT,*3
- +43 ; (06) Health Record Number
- WRITE *2,!,HRCN,*3
- +44 ; (07) Location
- WRITE *2,!,LOCVAR,*3
- +45 ; (08) Patient Name
- WRITE *2,!,$EXTRACT(PNM,1,27),*3
- +46 ; (09) Urgency
- WRITE *2,!,BLRURG,*3
- +47 ; (10) Accession Number -- Bar Coded
- WRITE *2,!,$EXTRACT("0000",$LENGTH(LRAN),4)_LRAN,*3
- +48 WRITE *2,*23,*15,"S30",*12,*3
- +49 ;
- +50 ;IHS/DIR TUC/AAB 03/23/98
- KILL BLRURG
- +51 ;----- END IHS MODIFICATIONS LR*5.2*1018 IHS/ITSC/MKK
- +52 QUIT
- PRT ;plain label..no barcode
- +1 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018 IHS/ITSC/MKK
- +2 ; Make certain DOB has something in it
- +3 ; Date Of Birth STRing
- NEW DOBSTR
- +4 ; Initialize to nonsense
- SET DOBSTR="XX/XX/XX"
- +5 ; If something there, set to real date
- IF $GET(DOB)'=""
- Begin DoDot:1
- +6 SET X=$GET(DOB)
- +7 SET %DT=""
- +8 DO ^%DT
- +9 SET DOBSTR=" DoB:"_$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_($EXTRACT(Y,1,3)+1700)
- End DoDot:1
- +10 ;
- +11 ; Make certain date string has a 2-digit year
- +12 ; LaboRatory SHort date
- NEW LRDSHRT
- +13 ; Initialize
- SET LRDSHRT=LRDAT
- +14 IF $LENGTH($PIECE($PIECE(LRDAT,"/",3)," ",1))>2
- Begin DoDot:1
- +15 SET LRDSHRT=$PIECE(LRDAT,"/",1,2)_"/"_$EXTRACT($PIECE(LRDAT,"/",3),3,$LENGTH(LRDAT))
- End DoDot:1
- +16 ;
- +17 ; Make certain provider name has data
- +18 ; Provider Name
- NEW PROVN
- +19 ; Initialize
- SET PROVN=""
- +20 ; Provider Pointer
- NEW PTR
- +21 IF $GET(LRAA)'=""&($GET(LRAD)'="")&($GET(LRAN)'="")
- Begin DoDot:1
- +22 SET PTR=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",8)
- +23 IF $GET(PTR)'=""
- SET PROVN=$PIECE($GET(^VA(200,PTR,0)),"^",1)
- End DoDot:1
- +24 ;
- +25 ; Location variable
- +26 ; LOCation VARiable
- NEW LOCVAR
- +27 SET LOCVAR="W:"_$EXTRACT(LRLLOC,1,7)
- +28 ; If Bed variable exists, get it
- IF $LENGTH(LRRB)>0
- SET LOCVAR=LOCVAR_" B:"_LRRB
- +29 ;
- +30 ; TEST(S) VARiable
- NEW TESTSVAR
- +31 SET TESTSVAR=$EXTRACT(LRTXT,1,32)
- +32 IF $LENGTH(LRTXT)>31
- SET TESTSVAR=TESTSVAR_"..."
- +33 ;
- +34 ; Urgency variable
- +35 ; Initialize
- SET BLRURG=""
- +36 ;IHS/DIR TUC/AAB 03/23/98
- SET LRURG0=$GET(LRURG0)
- IF LRURG0'=""
- SET BLRURG=$EXTRACT($PIECE(^LAB(62.05,LRURG0,0),U,1),1,4)
- +37 ;
- +38 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1019 IHS/ITSC/MKK
- +39 ; Using $G in case any of the variables are null -- an issue with testing labels
- +40 WRITE *2,"R",*3
- +41 ; Test(s)
- WRITE *2,*27,"E2",*24,!,$GET(TESTSVAR),*3
- +42 ; Collection sample - tube top/specimen
- WRITE *2,!,$GET(LRTOP),*3
- +43 ; Order Number
- WRITE *2,!,"Order#:",$GET(LRCE),*3
- +44 ; Accession string
- WRITE *2,!,$GET(LRACC),*3
- +45 ; Date
- WRITE *2,!,$GET(LRDSHRT),*3
- +46 ; Health Record Number
- WRITE *2,!,$GET(HRCN),*3
- +47 ; Location
- WRITE *2,!,$GET(LOCVAR),*3
- +48 ; Patient Name
- WRITE *2,!,$GET(PNM),*3
- +49 ; Urgency
- WRITE *2,!,$GET(BLRURG),*3
- +50 ; Sex
- WRITE *2,!,"Sex:",$GET(SEX),*3
- +51 ; Provider
- WRITE *2,!,"Prov:"_$EXTRACT($GET(PROVN),1,18),*3
- +52 ; Date of Birth
- WRITE *2,!,$GET(DOBSTR),*3
- +53 ;----- END IHS MODIFICATIONS LR*5.2*1019 IHS/ITSC/MKK
- +54 ;
- +55 WRITE *2,*23,*15,"S30",*12,*3
- +56 ;----- END IHS MODIFICATIONS LR*5.2*1018 IHS/ITSC/MKK
- +57 QUIT
