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