Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BLRSHPML

BLRSHPML.m

Go to the documentation of this file. 
  1. BLRSHPML ;cmi/anch/maw - BLR Reference Lab Shipping Manifest: Others ; 18-May-2016 11:26 ; MAW
  1.  ;;5.2;IHS LABORATORY;**1027,1028,1031,1034,1039,1040**;NOV 01, 1997;Build 5
  1.  ;
  1.  ;
  1.  ;
  1.  ;10/17/2005 cmi/anch/maw added reprint of shipping manifest
  1.  ;3/28/2006 cmi/anch/maw added device close before print and before storing
  1.  ;8/2/2006 cmi/anch/maw added telephone number for labcorp per DKR
  1.  ;5/16/2007 cmi/anch/maw made changes to layout in WRTS
  1.  ;12/12/2007 cmi/anch/maw split order comment print in WRTS
  1.  ;2/4/2008 cmi/anch/maw added sort on UID and added home phone to manifest
  1.  ;2/26/2008 cmi/anch/maw added lab reference number and shipping manifest custom header
  1.  ;4/4/2008 cmi/anch/maw added dx and insurance info
  1.  ;7/29/2008 cmi/anch/maw added lab shipping instructions
  1.  ;8/28/2008 cmi/anch/maw added call to go to quest manifest
  1.  ;10/1/2008 cmi/anch/maw masked all but 4 digits on SSN at labcorp request
  1.  ;4/11/2016 ihs/cmi/maw added written authorization
  1.  ;
  1.  ;
  1. PRT(CP) ;EP - print shipping manifest
  1.  Q:'$D(^TMP("BLRRL",$J))  ;don't print shipping manifest if no data
  1.  W:'+$G(BLRAGUI) !!,"Now printing shipping manifest for this accession"
  1.  D ^%ZISC  ;maw 3/28/2006
  1.  I '$G(CP) S CP=1
  1.  U $$DEV
  1.  F I=1:1:CP D
  1.  . D NEWPRT
  1.  . I $G(CP)>1 W @IOF
  1.  ;D WA^BLRSHPL2  ;written authorization p1039
  1.  D ^%ZISC  ;maw 3/28/2006
  1.  I I=1 D STOR(.BLRSHIEN,^TMP("BLRRL",$J,"COMMON","UID"))  ;store the shipping manifest as well as print
  1.  D EOJ
  1.  Q
  1.  ;
  1. NEWPRT  ;-now want copies
  1.  S BLRFAC=$$GET1^DIQ(9999999.06,$S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),.01)
  1.  S BLRSTR=$$GET1^DIQ(9999999.06,$S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),.14)
  1.  S BLRCTY=$$GET1^DIQ(9999999.06,$S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),.15)
  1.  S BLRST=$$GET1^DIQ(9999999.06,$S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),.16)
  1.  S BLRZIP=$$GET1^DIQ(9999999.06,$S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),.17)
  1.  N BLRPH
  1.  S BLRPH=$$GET1^DIQ(9999999.06,$S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),.13)
  1.  S BLRCHT=$$HRN^AUPNPAT(^TMP("BLRRL",$J,"COMMON","PAT"),DUZ(2))
  1.  S BLRURG=$P($G(^LAB(62.05,^TMP("BLRRL",$J,"COMMON","URG"),0)),U)
  1.  S BLRPGC=$$GETPG
  1.  S BLRNPG=1
  1.  D ALL
  1.  Q
  1.  ;
  1. ALL ;-- run all sub routines after initial vars
  1.  D XHDR
  1.  D PHDR
  1.  D WRTS
  1.  Q
  1.  ;
  1. STOR(BLRSHIEN,ACC) ;-- this will store the shipping manifest
  1.  N BLRFDA,BLRIENS,BLRERR
  1.  S BLRIENS=""
  1.  S BLRFDA(9009026.2,"+1,",.01)=ACC
  1.  S BLRFDA(9009026.2,"+1,",.02)=DUZ
  1.  S BLRFDA(9009026.2,"+1,",.03)=DT
  1.  D UPDATE^DIE("","BLRFDA","BLRIENS","BLRERR(1)")
  1.  I $D(BLRERR(1)) S BLRSHIEN=0 Q
  1.  S BLRSHIEN=+BLRIENS(1)
  1.  K ^TMP($J,"BLRSHPM")  ;cmi/anch/maw 4/4/2006
  1.  D GUIR^XBLM("ALL^BLRSHPML","^TMP($J,""BLRSHPM"",")
  1.  N X
  1.  S X=0,C=0 F  S X=$O(^TMP($J,"BLRSHPM",X)) Q:X'=+X  D
  1.  . S ^BLRSHPM(BLRSHIEN,11,X,0)=^TMP($J,"BLRSHPM",X),C=C+1
  1.  S ^BLRSHPM(BLRSHIEN,11,0)="^^"_C_"^"_C_"^"_DT_"^"
  1.  S DA=BLRSHIEN,DIK="^BLRSHPM(" D IX1^DIK
  1.  Q
  1.  ;
  1. SPHDR ;-- sub patient header
  1.  Q:'$P($G(^BLRSITE(DUZ(2),"RLA")),U,17)
  1. PHDR ;-- write the common stuff to the device
  1.  W !!,"ORDER (Control): "_^TMP("BLRRL",$J,"COMMON","ORD")
  1.  W ?30,"ORDER DATE: "_$$FMTE^XLFDT(^TMP("BLRRL",$J,"COMMON","ODT"))
  1.  W ?60,"MID: "_$$MID(+$G(BHLMSG))
  1.  W !,"PATIENT: "_$P($G(^DPT(^TMP("BLRRL",$J,"COMMON","PAT"),0)),U)
  1.  W ?30,"Chart # (Alt Patn ID): "_$$LZERO(BLRCHT,6),?60,"PHONE: "_$S($P($G(^BLRSITE(DUZ(2),"RL")),U,17):$P($G(^DPT(^TMP("BLRRL",$J,"COMMON","PAT"),.13)),U),1:"")  ;cmi/maw 2/4/2008 added home phone
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
  1.  ;       DOB must be in human-readable format 
  1.  W !,"SEX: "_$G(SEX),?10,"DOB: "_$S(+$G(DOB)>1950101:$$FMTE^XLFDT(DOB),1:$G(DOB))
  1.  W ?30,"SSN: "_$S($P($G(^DPT(^TMP("BLRRL",$J,"COMMON","PAT"),0)),U,9)]"":"XXX-XX-"_$E($P($G(^DPT(^TMP("BLRRL",$J,"COMMON","PAT"),0)),U,9),6,9),1:"NOT ON FILE")
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1031
  1.  ;W !,"LOCATION: "_^TMP("BLRRL",$J,"COMMON","LOC"),?55,"Bill Type: Client" cmi/maw 10/31/07 orig line
  1.  W !,"LOCATION: "_^TMP("BLRRL",$J,"COMMON","LOC")
  1.  ;W ?30,"BILL TYPE: "_$S($E($G(^TMP("BLRRL",$J,"COMMON","BILL TYPE")),1,1)="T":$G(^TMP("BLRRL",$J,"COMMON","INSTYP")),$E($G(^TMP("BLRRL",$J,"COMMON","BILL TYPE")),1,1)="P":"Patient",1:"Client")  ;cmi/maw 10/31/07 new line
  1.  W ?30,"BILL TYPE: "_$S($E($G(^TMP("BLRRL",$J,"COMMON","BILL TYPE")),1,1)="T":"Private Insurance",$E($G(^TMP("BLRRL",$J,"COMMON","BILL TYPE")),1,1)="P":"Patient",1:"Client")  ;cmi/maw 04/04/2011 per labcorp request
  1.  ;cmi/maw 2/29/2008 added UPIN/NPI print based on site parameter
  1.  W !,"PRACTITIONER: "_$P(^TMP("BLRRL",$J,"COMMON","ORDPNM"),U)_", "_$P(^TMP("BLRRL",$J,"COMMON","ORDPNM"),U,2)
  1.  W ?55,$S($P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,19)="N":"NPI: "_$G(^TMP("BLRRL",$J,"COMMON","ORDPNPI")),1:"UPIN: "_$G(^TMP("BLRRL",$J,"COMMON","ORDPUPIN")))
  1.  W !,"LAB ARRIVAL (COLLECTION DATE/TIME): "_$$FMTE^XLFDT(^TMP("BLRRL",$J,"COMMON","CDT"))
  1.  Q
  1.  ;
  1. WRTS ;-- write the output to the device
  1.  N BLRDA,BLRIEN
  1.  S BLRDA=0 F  S BLRDA=$O(^TMP("BLRRL",$J,BLRDA)) Q:BLRDA=""  D
  1.  . Q:BLRDA="COMMON"
  1.  . S BLRSAMP=$P($G(^LAB(62,^TMP("BLRRL",$J,BLRDA,"SAMP"),0)),U)
  1.  . I $Y+($$CHKOEQ(BLRDA))>IOSL D XHDR,SPHDR Q:$D(DIRUT)  ;p1039 ,PHDR Q:$G(DIRUT) p1040 added SPHDR
  1.  . I $Y+2>IOSL D XHDR Q:$D(DIRUT)  ;p1039 ,PHDR Q:$G(DIRUT)
  1.  . W !!!,"TEST NAME: "_$P(^TMP("BLRRL",$J,BLRDA,"TCNM"),U,2)_" ("_$P(^TMP("BLRRL",$J,BLRDA,"TCNM"),U)_")"
  1.  . W ?45,"SAMPLE: "_BLRSAMP
  1.  . W !,"SOURCE: "_^TMP("BLRRL",$J,BLRDA,"SRC")
  1.  . W ?45,"Accession/Alt cnt#(CD): "_^TMP("BLRRL",$J,BLRDA,"UID")
  1.  . W !,?45,"URGENCY: "_BLRURG
  1.  . W !,"LAB PROCESSING INSTR: "_$$LABINST(BLRDA,^TMP("BLRRL",$J,BLRDA,"SAMP"))
  1.  . I $O(^TMP("BLRRL",$J,BLRDA,"COMMENT",0)) D
  1.  .. W !!,"ORDER ENTRY QUESTIONS: "
  1.  .. N BLRODA
  1.  .. S BLRODA=0 F  S BLRODA=$O(^TMP("BLRRL",$J,BLRDA,"COMMENT",BLRODA)) Q:'BLRODA  D
  1.  ... S ORDC=$G(^TMP("BLRRL",$J,BLRDA,"COMMENT",BLRODA))
  1.  ... W !,?5,$P(ORDC,U,2),!,?5,$P(ORDC,U,3)  ;cmi/maw 12/12/2007 split line here
  1.  . I $O(LRTCOM(BLRDA,0)) D
  1.  .. W !!,"COMMENTS: "
  1.  .. N BLRUDA
  1.  .. S BLRUDA=0 F  S BLRUDA=$O(LRTCOM(BLRDA,BLRUDA)) Q:'BLRUDA  D
  1.  ... Q:$G(LRTCOM(BLRDA,BLRUDA))["For Test"  ;filter
  1.  ... W !,?5,$TR($G(LRTCOM(BLRDA,BLRUDA)),"~")
  1.  . D DX(BLRDA)
  1.  . D INS(BLRDA)
  1.  W !!
  1.  Q
  1.  ;
  1. DX(BDA) ;-- if insurance info print DX
  1.  Q:'$G(BDA)
  1.  Q:'$D(^TMP("BLRRL",$J,"COMMON","DX"))
  1.  W !,"DIAGNOSIS"
  1.  ;W !,"Diagnosis: "_$G(^TMP("BLRRL",$J,BDA,"DX")),?25,"DX Description: "_$G(^TMP("BLRRL",$J,BDA,"DXE"))
  1.  W !,"Diagnosis: ",?25,"DX Description: "
  1.  ;N DXDA
  1.  ;S DXDA=0 F  S DXDA=$O(^TMP("BLRRL",$J,BDA,"DX",DXDA)) Q:'DXDA  D
  1.  ;. W !,$G(^TMP("BLRRL",$J,BDA,"DX",DXDA)),?25,$G(^TMP("BLRRL",$J,BDA,"DXE",DXDA))
  1.  ;ihs/cmi/maw 12/10/2014 patch 1034 for new dx storage
  1.  N DXDA,ORD,ORDI,DXDATA,DXSTR,UID
  1.  S UID=^TMP("BLRRL",$J,BLRDA,"UID")
  1.  I '$G(UID) S UID=LRUID
  1.  S ORD=$O(^BLRRLO("ACC",UID,0))
  1.  S ORDI=0 F  S ORDI=$O(^BLRRLO(ORD,1,ORDI)) Q:'ORDI  D
  1.  . S DXDATA=$P($G(^BLRRLO(ORD,1,ORDI,0)),U)
  1.  . S DXSTR=$S($D(^ICDS(0)):$$ICDDX^ICDEX(DXDATA,DT),1:$$ICDDX^ICDCODE(DXDATA,DT))
  1.  . W !,$P(DXSTR,U,2),?25,$P(DXSTR,U,4)
  1.  Q
  1.  ;
  1. INS(BDA) ;-- if insurance info print insurance
  1.  Q:'$G(BDA)
  1.  Q:'$D(^TMP("BLRRL",$J,"COMMON","INSE"))
  1.  W !!,"PRIMARY INSURANCE"
  1.  W !,"Ins Carrier Code: "_$G(^TMP("BLRRL",$J,BDA,"INSID")),?40,"Insured Name: "_$E($G(^TMP("BLRRL",$J,BDA,"INSNOIE")),1,26)
  1.  W !,?40,"Relationship: "_$G(^TMP("BLRRL",$J,BDA,"INSRELE"))
  1.  W !,"Insurer Name: ",$E($G(^TMP("BLRRL",$J,BDA,"INSCNME")),1,30),?40,"Insured Add: "_$P($G(^TMP("BLRRL",$J,BDA,"PATADDE")),"~")
  1.  W !,"Insurer Add: ",?54,$P($G(^TMP("BLRRL",$J,BDA,"PATADDE")),"~",2)
  1.  W !,$P($G(^TMP("BLRRL",$J,BDA,"INSADDE")),"~"),?40,"Guarantor: "_$E($G(^TMP("BLRRL",$J,BDA,"GT1NME")),1,25)
  1.  W !,$P($G(^TMP("BLRRL",$J,BDA,"INSADDE")),"~",2),?40,"Guar Add: "_$P($G(^TMP("BLRRL",$J,BDA,"GT1ADDE")),"~")
  1.  W !,"Insurer Group: "_$G(^TMP("BLRRL",$J,BDA,"INSGRP")),?50,$P($G(^TMP("BLRRL",$J,BDA,"GT1ADDE")),"~",2)
  1.  W !,"Insured ID: "_$G(^TMP("BLRRL",$J,BDA,"INSPOL")),?40,"Guarantor Phone: "_$G(^TMP("BLRRL",$J,BDA,"GT1PHO"))
  1.  W !
  1.  D CHKSECI(^TMP("BLRRL",$J,"COMMON","PAT"))
  1.  W !
  1.  N J
  1.  F J=1:1:80 W "-"  ;write hyphens to separate
  1.  Q
  1.  ;
  1. CHKSECI(PAT,COUNTER) ;-- check to see if secondary insurance for labcorp
  1.  N CD,CNT,SEQ
  1.  S SECFLG=0
  1.  S DFN=PAT
  1.  D ^AGINS
  1.  Q:'$D(AGINS(1))
  1.  S CD=$S($G(^TMP("BLRRL",$J,"COMMON","CDT"))]"":^TMP("BLRRL",$J,"COMMON","CDT"),1:DT)
  1.  D SEQINS(.AGINS,PAT,CD)
  1.  S CNT=0
  1.  S SEQ=0 F  S SEQ=$O(BLRSEQ(SEQ)) Q:'SEQ  D
  1.  . S CNT=CNT+1
  1.  . Q:CNT<2
  1.  . Q:CNT>2
  1.  . S SECFLG=1
  1.  . I '$G(COUNTER) D PRTSECI^BLRSHPL2(BLRSEQ(SEQ),PAT)
  1.  Q
  1.  ;
  1. SEQINS(BINS,PT,RLCDT) ;-- lets go through sequencing insurers
  1.  Q:'$O(BINS(""))
  1.  K BLRSEQ  ;ihs/cmi/maw 10/07/2013 patch 1033
  1.  N BDA
  1.  S BDA=0 F  S BDA=$O(BINS(BDA)) Q:'BDA  D
  1.  . N BINI,SEQ,POLI
  1.  . S BINI=$P(BINS(BDA),U,2)
  1.  . S POLI=$P(BINS(BDA),U,9)
  1.  . S SEQ=$$FNDSEQ(BINI,PT,POLI,RLCDT)
  1.  . Q:'SEQ
  1.  . S BLRSEQ(SEQ)=$G(BINS(BDA))
  1.  Q
  1.  ;
  1. FNDSEQ(BN,PTI,POL,CDT) ;-- find the category prioritization
  1.  N SQDA,EFF,SQPRI
  1.  S EFF=$O(^AUPNICP("EFF",PTI,"M",""),-1)
  1.  I '$G(EFF) Q ""
  1.  S SQDA=0 F  S SQDA=$O(^AUPNICP("EFF",PTI,"M",EFF,SQDA)) Q:'SQDA!($G(SQPRI))  D
  1.  . N SQDATA,SQPAT,SQPOL,SQINS
  1.  . S SQDATA=$G(^AUPNICP(SQDA,0))
  1.  . S SQPAT=$P(SQDATA,U,2)
  1.  . S SQINS=$P(SQDATA,U,3)
  1.  . S SQPOL=$P(SQDATA,U,10)
  1.  . Q:SQPAT'=PTI
  1.  . Q:SQINS'=BN
  1.  . Q:SQPOL'=POL
  1.  . S SQPRI=$P(SQDATA,U,5)
  1.  Q $G(SQPRI)
  1.  ;
  1. INSTYP(TYP) ;-- get insurance type
  1.  N TYPE
  1.  I $G(TYP)]"" D
  1.  . I TYP="H" S TYPE="HMO"
  1.  . I TYP="MD" S TYPE="Medicare"
  1.  . I TYP="M" S TYPE="Medicare"
  1.  . I TYP="P" S TYPE="Private Insurance"
  1.  . I TYP="D" S TYPE="Medicaid"
  1.  . I TYP="R" S TYPE="Medicare"
  1.  . I TYP="MH" S TYPE="Medicaid"
  1.  I TYP="" S TYPE="Private Insurance"
  1.  Q $G(TYPE)
  1.  ;
  1. LABINST(TST,SAMP) ;-- get the lab processing instructions
  1.  I '$G(SAMP) Q ""
  1.  N IDA,INST,SAMPI
  1.  I '$D(^LAB(60,TST,3,"B",SAMP)) Q ""
  1.  S SAMPI=$O(^LAB(60,TST,3,"B",SAMP,0))
  1.  I '$G(SAMPI) Q ""
  1.  S INST=""
  1.  S IDA=0 F  S IDA=$O(^LAB(60,TST,3,SAMPI,2,IDA)) Q:'IDA  D
  1.  . S INST=INST_" "_$G(^LAB(60,TST,3,SAMPI,2,IDA,0))
  1.  Q INST
  1.  ;
  1. CHKOEQ(CDA) ;-- check the number of order entry questions to determine lines left
  1.  N BLRLN
  1.  S BLRLN=3
  1.  N BLRCDA,BLRCNT
  1.  S BLRCNT=0
  1.  S BLRCDA=0 F  S BLRCDA=$O(^TMP("BLRRL",$J,CDA,"COMMENT",BLRCDA)) Q:'BLRCDA  D
  1.  . S BLRCNT=BLRCNT+1
  1.  Q $G(BLRLN)+(+$G(BLRCNT))
  1.  ;
  1. GETPG() ;-- lets try and get a page count
  1.  ;S BLRHDC=8
  1.  ;S BLRPDC=9
  1.  S BLRWTC=9
  1.  N BLRNDA,BLRNCNT,BLRNIEN,BLRCMCNT,BLRNACC,BLRDXCNT,BLRPGG,BLRIC,BLRSC
  1.  S BLRNDA=0,BLRNCNT=0,BLRCMCNT=0,BLRNACC=0,BLRDXCNT=0
  1.  F  S BLRNDA=$O(^TMP("BLRRL",$J,BLRNDA)) Q:'BLRNDA  D
  1.  . S BLRNACC=BLRNACC+1
  1.  . S BLRDXCNT=BLRDXCNT+$$GETDXCNT(BLRNDA)
  1.  . S BLRNIEN=0 F  S BLRNIEN=$O(^TMP("BLRRL",$J,BLRNDA,"COMMENT",BLRNIEN)) Q:'BLRNIEN  D
  1.  .. S BLRCMCNT=BLRCMCNT+1
  1.  S BLRNACC=(BLRNACC*BLRWTC)
  1.  S BLRDXCNT=(BLRDXCNT*3)
  1.  ;S BLRNCNT=(BLRHDC+BLRPDC+BLRNACC+(+$G(BLRCMCNT)))
  1.  S BLRNCNT=(BLRNACC+(+$G(BLRCMCNT)))
  1.  N BLRINSCN,BLRSECC
  1.  I $D(^TMP("BLRRL",$J,"COMMON","INSE")) D
  1.  . S BLRINSCN=12
  1.  . D CHKSECI(^TMP("BLRRL",$J,"COMMON","PAT"),1)
  1.  I $G(SECFLG) S BLRSECC=10
  1.  S BLRNCNT=BLRNCNT+(+$G(BLRDXCNT))
  1.  S BLRPGG=(BLRNCNT/(IOSL-2))
  1.  I $E($P(BLRPGG,".",2),1,1)>4 S BLRPGG=$P(BLRPGG,".")+1
  1.  S BLRHDC=(8*BLRPGG)
  1.  S BLRPDC=$S($P($G(^BLRSITE(DUZ(2),"RLA")),U,17):(9*BLRPGG),1:9)
  1.  S BLRIC=(12*BLRPGG)
  1.  I $G(SECFLG) S BLRSC=(10*BLRPGG)
  1.  S BLRNCNT=BLRNCNT+BLRPDC+BLRHDC+BLRIC+(+$G(BLRSC))
  1.  S BLRPG=(BLRNCNT/(IOSL-2))
  1.  S BLRPGP=$P(BLRPG,".")
  1.  S BLRPGE=$P(BLRPG,".",2)
  1.  I BLRPGE>0 S BLRPGP=BLRPGP+1
  1.  Q BLRPGP
  1.  ;
  1. GETDXCNT(BDA) ;-- get number of dx to display
  1.  N DXCNT,ORD,ORDI,DXDATA,DXSTR,UID
  1.  S DXCNT=0
  1.  S UID=^TMP("BLRRL",$J,BDA,"UID")
  1.  I '$G(UID) S UID=LRUID
  1.  S ORD=$O(^BLRRLO("ACC",UID,0))
  1.  S ORDI=0 F  S ORDI=$O(^BLRRLO(ORD,1,ORDI)) Q:'ORDI  D
  1.  . S DXCNT=DXCNT+1
  1.  Q DXCNT
  1.  ;
  1. WRT(SDA) ; -- write the output to the device
  1.  S BLRSAMP=$P($G(^LAB(62,RL(SDA,"SAMP"),0)),U)
  1.  W !,"ORDER (CTRL): "_RL("ORD")
  1.  W ?40,"ACCESSION: "_RL(SDA,"ACC")
  1.  W !,"PATIENT: "_$P($G(^DPT(RL("PAT"),0)),U)
  1.  ; W ?40,"SEX: "_$G(SEX),?50,"DOB: "_$G(DOB)
  1.  W ?40,"SEX: "_$G(SEX),?50,"DOB: "_$S(+$G(DOB)>1950101:$$FMTE^XLFDT(DOB),1:$G(DOB)) ; IHS/MSC/MKK - LR*5.2*1032: DOB must be in human-readable format
  1.  W !,"CHART (PATIENT ID): "_BLRCHT
  1.  W !,"LOCATION: "_RL("LOC"),?40,"ORDER DATE: "_$$FMTE^XLFDT(RL("ODT"))
  1.  W !,"PRACTITIONER: "_RL("ORDPNM"),?55,"UPIN: "_$G(RL("ORDPUPIN"))
  1.  W !,"LAB ARRIVAL (COLLECTION DATE): "_$$FMTE^XLFDT(RL("CDT"))
  1.  W ?55,"SAMPLE: "_BLRSAMP
  1.  W !,"TEST NAME: "_$P(RL(SDA,"TCNM"),U,2)_" ("_$P(RL(SDA,"TCNM"),U)_")"
  1.  W ?55,"URGENCY: "_BLRURG
  1.  I $O(RL(SDA,"COMMENT",0)) D
  1.  . W !!,"ORDER ENTRY QUESTIONS: "
  1.  . S BLRODA=0 F  S BLRODA=$O(RL(SDA,"COMMENT",BLRODA)) Q:'BLRODA  D
  1.  .. S ORDC=$G(RL(SDA,"COMMENT",BLRODA))
  1.  .. W !,$P(ORDC,U),?15,$P(ORDC,U,2),?65,$P(ORDC,U,3)
  1.  W !!
  1.  Q
  1.  ;
  1. HDR ;-- this is the header
  1.  K DIR I $E(IOST,1)="C" S DIR(0)="E" D ^DIR I Y<1 S DIRUT=1 Q
  1. XHDR W @IOF
  1.  W !,?28,"INDIAN HEALTH SERVICE EREQ",?65,"PAGE: "_BLRNPG  ;_" of "_BLRPGC  1040
  1.  W !!,"REF LAB NAME: "_$S($P($G(^BLRSITE(DUZ(2),"RL")),U,20)]"":$P(^BLRSITE(DUZ(2),"RL"),U,20),1:$P($G(^BLRRL(^TMP("BLRRL",$J,"COMMON","RL"),0)),U))  ;cmi/maw 2/28/2008 added for custon header on ship manifest.
  1.  W ?40,"CLIENT #: "_^TMP("BLRRL",$J,"COMMON","CLIENT")
  1.  W !
  1.  W !,"FACILITY: "_BLRFAC,?40,$$FMTE^XLFDT($$NOW)
  1.  W !,"ADDRESS: "_BLRSTR_", "_BLRCTY_", "_$$ST(BLRST)_" "_BLRZIP_"  PHONE: "_$G(BLRPH)
  1.  W !
  1.  F BLRI=1:1:80 W "="
  1.  W !
  1.  S BLRNPG=BLRNPG+1   ;cmi/flag/maw increment current page
  1.  Q
  1.  ;
  1. MID(MSG) ;-- get message id
  1.  I 'MSG Q ""
  1.  S MIEN=$O(^INTHU("AT",MSG,0))
  1.  I 'MIEN Q ""
  1.  Q $P($G(^INTHU(MIEN,0)),U,5)_" ("_MIEN_")"
  1.  ;
  1. EOJ ;-- kill vars and quit     
  1.  D ^%ZISC
  1.  ;K ^TMP("BLRRL",$J)
  1.  K ^TMP($J,"BLRSHPM")  ;cmi/anch/maw 4/4/2006
  1.  K BLRODA,DIRUT,ORDC,BLRSDA,MIEN,MSG,BLRRLCNT,BLRRLASK,BLRRLCLT,BLRRLCLA,BLRRLBTP,BLRDX,BLRDXCNT,SECFLG
  1.  Q
  1.  ;
  1. DEV() ;-- device handler
  1.  ;S DEV=$S($G(^TMP("BLRRL",$J,"COMMON","RL")):$P($G(^BLRRL(^TMP("BLRRL",$J,"COMMON","RL"),0)),U,14),1:"")  ;reference lab file
  1.  S DEV=$S($P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,2)]"":$P($G(^BLRSITE(DUZ(2),"RL")),U,2),1:"")  ;blr master control file
  1.  I DEV D  Q IO
  1.  . S IOP="`"_DEV
  1.  . D ^%ZIS
  1.  D ^%ZIS
  1.  Q IO
  1.  ;
  1. ST(ST) ;-- get state abbreviation
  1.  I ST="" Q ""
  1.  S BST=$P($G(^DIC(5,ST,0)),U,2)
  1.  Q BST
  1.  ;
  1. NOW() ;-- return now
  1.  D NOW^%DTC
  1.  Q %
  1.  ;
  1. LZERO(V,L) ;EP - left zero fill
  1.  NEW %,I
  1.  S %=$L(V),Z=L-% F I=1:1:Z S V="0"_V
  1.  Q V
  1.  ;
  1. REP ;EP - lets reprint the shipping manifest
  1.  I $P($G(^BLRRL($P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U),0)),U)["QUEST" D  Q  ;go to the Quest Manifest
  1.  . D REP^BLRSHPMQ
  1.  D ASKS
  1.  I '$G(BLRRIEN) K BLRRIEN Q
  1.  D RPRT(BLRRIEN)
  1.  D ^%ZISC
  1.  K BLRRIEN
  1.  Q
  1.  ;
  1. ASKS ;-- get the ien of the entry
  1.  S DIR(0)="P^9009026.2",DIR("A")="Reprint for which Accession Number (UID) "
  1.  D ^DIR
  1.  Q:$D(DIRUT)
  1.  S BLRRIEN=+Y
  1.  Q
  1.  ;
  1. RPRT(RIEN) ;-- reprint
  1.  U $$DEV
  1.  N BLRDA
  1.  S BLRDA=0 F  S BLRDA=$O(^BLRSHPM(RIEN,11,BLRDA)) Q:'BLRDA  D
  1.  . W !,$G(^BLRSHPM(RIEN,11,BLRDA,0))
  1.  Q
  1.  ;