BLRSHPM ;cmi/anch/maw - BLR Reference Lab Shipping Manifest Others ; 22-Apr-2016 15:14 ; MAW
;;5.2;IHS LABORATORY;**1027,1031,1033,1034,1036,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
;09/19/2013 msc/mkk - missing variables reset subroutine P1031FIX.
;
PRT(RE,CP) ;EP - print shipping manifest
;ihs/cmi/maw PATCH 1033 10/24/2013 added since LRUID is not there sometimes after patch 1031
I $G(LRUID),'$G(RE) G:$D(^BLRSHPM("B",LRUID)) EOJ ; Quit if Accession exists in ^BLRSHPM because it's already been printed
;
I $G(LRUID) D P1031FIX ; IHS/MSC/MKK - LR*5.2*1033/1034
I $P($G(^BLRRL($P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U),0)),U)["LABCORP" D Q ;go to the Quest Manifest
. D PRT^BLRSHPML(CP)
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 ^%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
Q:$D(^BLRSHPM("B",ACC)) ; Skip if already stored
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^BLRSHPM","^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 (Patient 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
; W !,"SEX: "_$G(SEX),?10,"DOB: "_$G(DOB),?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") ;cmi/maw 10/1/08 mask ssn
; ----- 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
;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
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
P1031FIX ; EP - Forcefully reset AGE, DOB, ORDNUM, and SEX variables
NEW ALLGOOD,DFN,LRAA,LRAD,LRAN,LRAS,LRDFN,LRIDT,LRSS,ORDNUM
;
; Check to see if all variables okay
S ALLGOOD=1
S:$G(SEX)="" ALLGOOD=0
S:+$G(DOB)<1 ALLGOOD=0
S:+$G(AGE)<1 ALLGOOD=0
S:+$G(BLRRL("ORD"))<1 ALLGOOD=0
S:+$G(^TMP("BLRRL",$J,"COMMON","ORD"))<1 ALLGOOD=0
Q:ALLGOOD ; All variables set - just return
;
D RETACCV^BLRUTIL4(LRUID,.LRAA,.LRAD,.LRAN,.LRDFN,.LRSS,.LRIDT,.LRAS)
Q:LRAA<1!(LRAD<1)!(LRAN<1)!(LRDFN<1) ; If any Accession variables null, then exit
;
Q:$$GET1^DIQ(63,LRDFN,"PARENT FILE","I")'=2 ; If data not from VA PATIENT file, then exit
;
S DFN=$$GET1^DIQ(63,LRDFN,"NAME","I") ; Get Patient IEN from Lab Data (#63) File
; Set AGE, DOB & SEX (if missing) from VA Patient (#2) File
S:$G(SEX)="" SEX=$$SEX^AUPNPAT(DFN)
S:+$G(DOB)<1 DOB=$$DOB^AUPNPAT(DFN)
S:+$G(AGE)<1 AGE=$$AGE^AUPNPAT(DFN)
;
; Get Order # from Accession (#68) File
S ORDNUM=+$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",","ORDER #")
Q:ORDNUM<1 ; If order # is zero, can't reset, so just return
;
; Set Order number (if missing)
S:+$G(BLRRL("ORD"))<1 BLRRL("ORD")=ORDNUM
S:+$G(^TMP("BLRRL",$J,"COMMON","ORD"))<1 ^TMP("BLRRL",$J,"COMMON","ORD")=ORDNUM
Q
; ----- END IHS/MSC/MKK - LR*5.2*1033
;
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 Q:$D(DIRUT) ; p1039 ,PHDR Q:$G(DIRUT)
. 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,SPHDR 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 (Lab Ref#): "_^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: ",?25,"DX Description: "
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 !!,"INSURANCE"
W !,"Insurer ID: "_$G(^TMP("BLRRL",$J,BDA,"INSID")),?40,"Insured Name: "_$E($G(^TMP("BLRRL",$J,BDA,"INSNOIE")),1,26)
W ?68,"Rel: "_$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 !
N I
F I=1:1:80 W "-" ;write hyphens to separate
Q
;
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=7
S BLRWTC=8
N BLRNDA,BLRNCNT,BLRNIEN,BLRCMCNT,BLRNACC,BLRDXCNT
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=(BLRWTC*BLRNACC)
S BLRNCNT=(BLRHDC+BLRPDC+BLRNACC+(+$G(BLRCMCNT)))
N BLRINSCN,BLRSECC
I $D(^TMP("BLRRL",$J,"COMMON","INSE")) D
. S BLRINSCN=11
S BLRNCNT=BLRNCNT+(+$G(BLRDXCNT)+(+$G(BLRINSCN)))
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*1031
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
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
I $P($G(^BLRRL($P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U),0)),U)["LABCORP" D Q ;go to the Quest Manifest
. D REP^BLRSHPML
D ASKS
I '$G(BLRRIEN) K BLRRIEN Q
D RPRT(BLRRIEN)
D ^%ZISC
K BLRRIEN
Q
;
ASKS ;-- get the ien of the entry
K DIR
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
;
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
TOSCREEN ; EP - Reprint to the screen
N BLRDA,BLRRIEN,RIEN
D ASKS
I '$G(BLRRIEN) K BLRRIEN Q
;
D ^XBCLS
S BLRDA=0 F S BLRDA=$O(^BLRSHPM(BLRRIEN,11,BLRDA)) Q:BLRDA<1 D
. W !,$G(^BLRSHPM(BLRRIEN,11,BLRDA,0))
;
D PRESSKEY^BLRGMENU(9)
Q
; ----- END IHS/MSC/MKK - LR*5.2*1034
BLRSHPM ;cmi/anch/maw - BLR Reference Lab Shipping Manifest Others ; 22-Apr-2016 15:14 ; MAW
+1 ;;5.2;IHS LABORATORY;**1027,1031,1033,1034,1036,1039,1040**;NOV 01, 1997;Build 5
+2 ;
+3 ;10/17/2005 cmi/anch/maw added reprint of shipping manifest
+4 ;3/28/2006 cmi/anch/maw added device close before print and before storing
+5 ;8/2/2006 cmi/anch/maw added telephone number for labcorp per DKR
+6 ;5/16/2007 cmi/anch/maw made changes to layout in WRTS
+7 ;12/12/2007 cmi/anch/maw split order comment print in WRTS
+8 ;2/4/2008 cmi/anch/maw added sort on UID and added home phone to manifest
+9 ;2/26/2008 cmi/anch/maw added lab reference number and shipping manifest custom header
+10 ;4/4/2008 cmi/anch/maw added dx and insurance info
+11 ;7/29/2008 cmi/anch/maw added lab shipping instructions
+12 ;8/28/2008 cmi/anch/maw added call to go to quest manifest
+13 ;10/1/2008 cmi/anch/maw masked all but 4 digits on SSN at labcorp request
+14 ;09/19/2013 msc/mkk - missing variables reset subroutine P1031FIX.
+15 ;
PRT(RE,CP) ;EP - print shipping manifest
+1 ;ihs/cmi/maw PATCH 1033 10/24/2013 added since LRUID is not there sometimes after patch 1031
+2 ; Quit if Accession exists in ^BLRSHPM because it's already been printed
IF $GET(LRUID)
IF '$GET(RE)
IF $DATA(^BLRSHPM("B",LRUID))
GOTO EOJ
+3 ;
+4 ; IHS/MSC/MKK - LR*5.2*1033/1034
IF $GET(LRUID)
DO P1031FIX
+5 ;go to the Quest Manifest
IF $PIECE($GET(^BLRRL($PIECE($GET(^BLRSITE($SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U),0)),U)["LABCORP"
Begin DoDot:1
+6 DO PRT^BLRSHPML(CP)
End DoDot:1
QUIT
+7 ;don't print shipping manifest if no data
IF '$DATA(^TMP("BLRRL",$JOB))
QUIT
+8 IF '+$GET(BLRAGUI)
WRITE !!,"Now printing shipping manifest for this accession"
+9 ;maw 3/28/2006
DO ^%ZISC
+10 IF '$GET(CP)
SET CP=1
+11 USE $$DEV
+12 FOR I=1:1:CP
Begin DoDot:1
+13 DO NEWPRT
+14 IF $GET(CP)>1
WRITE @IOF
End DoDot:1
+15 ;maw 3/28/2006
DO ^%ZISC
+16 ;store the shipping manifest as well as print
IF I=1
DO STOR(.BLRSHIEN,^TMP("BLRRL",$JOB,"COMMON","UID"))
+17 DO EOJ
+18 QUIT
+19 ;
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 ; Skip if already stored
IF $DATA(^BLRSHPM("B",ACC))
QUIT
+2 NEW BLRFDA,BLRIENS,BLRERR
+3 SET BLRIENS=""
+4 SET BLRFDA(9009026.2,"+1,",.01)=ACC
+5 SET BLRFDA(9009026.2,"+1,",.02)=DUZ
+6 SET BLRFDA(9009026.2,"+1,",.03)=DT
+7 DO UPDATE^DIE("","BLRFDA","BLRIENS","BLRERR(1)")
+8 IF $DATA(BLRERR(1))
SET BLRSHIEN=0
QUIT
+9 SET BLRSHIEN=+BLRIENS(1)
+10 ;cmi/anch/maw 4/4/2006
KILL ^TMP($JOB,"BLRSHPM")
+11 DO GUIR^XBLM("ALL^BLRSHPM","^TMP($J,""BLRSHPM"",")
+12 NEW X
+13 SET X=0
SET C=0
FOR
SET X=$ORDER(^TMP($JOB,"BLRSHPM",X))
IF X'=+X
QUIT
Begin DoDot:1
+14 SET ^BLRSHPM(BLRSHIEN,11,X,0)=^TMP($JOB,"BLRSHPM",X)
SET C=C+1
End DoDot:1
+15 SET ^BLRSHPM(BLRSHIEN,11,0)="^^"_C_"^"_C_"^"_DT_"^"
+16 SET DA=BLRSHIEN
SET DIK="^BLRSHPM("
DO IX1^DIK
+17 QUIT
+18 ;
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 (Patient 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 ; W !,"SEX: "_$G(SEX),?10,"DOB: "_$G(DOB),?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") ;cmi/maw 10/1/08 mask ssn
+7 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
+8 ; DOB must be in human-readable format
+9 WRITE !,"SEX: "_$GET(SEX),?10,"DOB: "_$SELECT(+$GET(DOB)>1950101:$$FMTE^XLFDT(DOB),1:$GET(DOB))
+10 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")
+11 ; ----- END IHS/MSC/MKK - LR*5.2*1031
+12 ;W !,"LOCATION: "_^TMP("BLRRL",$J,"COMMON","LOC"),?55,"Bill Type: Client" cmi/maw 10/31/07 orig line
+13 WRITE !,"LOCATION: "_^TMP("BLRRL",$JOB,"COMMON","LOC")
+14 ;cmi/maw 10/31/07 new line
WRITE ?30,"BILL TYPE: "_$SELECT($EXTRACT($GET(^TMP("BLRRL",$JOB,"COMMON","BILL TYPE")),1,1)="T":$GET(^TMP("BLRRL",$JOB,"COMMON","INSTYP")),$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 ;
+21 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
P1031FIX ; EP - Forcefully reset AGE, DOB, ORDNUM, and SEX variables
+1 NEW ALLGOOD,DFN,LRAA,LRAD,LRAN,LRAS,LRDFN,LRIDT,LRSS,ORDNUM
+2 ;
+3 ; Check to see if all variables okay
+4 SET ALLGOOD=1
+5 IF $GET(SEX)=""
SET ALLGOOD=0
+6 IF +$GET(DOB)<1
SET ALLGOOD=0
+7 IF +$GET(AGE)<1
SET ALLGOOD=0
+8 IF +$GET(BLRRL("ORD"))<1
SET ALLGOOD=0
+9 IF +$GET(^TMP("BLRRL",$JOB,"COMMON","ORD"))<1
SET ALLGOOD=0
+10 ; All variables set - just return
IF ALLGOOD
QUIT
+11 ;
+12 DO RETACCV^BLRUTIL4(LRUID,.LRAA,.LRAD,.LRAN,.LRDFN,.LRSS,.LRIDT,.LRAS)
+13 ; If any Accession variables null, then exit
IF LRAA<1!(LRAD<1)!(LRAN<1)!(LRDFN<1)
QUIT
+14 ;
+15 ; If data not from VA PATIENT file, then exit
IF $$GET1^DIQ(63,LRDFN,"PARENT FILE","I")'=2
QUIT
+16 ;
+17 ; Get Patient IEN from Lab Data (#63) File
SET DFN=$$GET1^DIQ(63,LRDFN,"NAME","I")
+18 ; Set AGE, DOB & SEX (if missing) from VA Patient (#2) File
+19 IF $GET(SEX)=""
SET SEX=$$SEX^AUPNPAT(DFN)
+20 IF +$GET(DOB)<1
SET DOB=$$DOB^AUPNPAT(DFN)
+21 IF +$GET(AGE)<1
SET AGE=$$AGE^AUPNPAT(DFN)
+22 ;
+23 ; Get Order # from Accession (#68) File
+24 SET ORDNUM=+$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",","ORDER #")
+25 ; If order # is zero, can't reset, so just return
IF ORDNUM<1
QUIT
+26 ;
+27 ; Set Order number (if missing)
+28 IF +$GET(BLRRL("ORD"))<1
SET BLRRL("ORD")=ORDNUM
+29 IF +$GET(^TMP("BLRRL",$JOB,"COMMON","ORD"))<1
SET ^TMP("BLRRL",$JOB,"COMMON","ORD")=ORDNUM
+30 QUIT
+31 ; ----- END IHS/MSC/MKK - LR*5.2*1033
+32 ;
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 ;I $Y+($$CHKOEQ(BLRDA))>IOSL D XHDR Q:$D(DIRUT) ; p1039 ,PHDR Q:$G(DIRUT)
+6 ; p1039 ,PHDR Q:$G(DIRUT) p1040 added SPHDR
IF $Y+($$CHKOEQ(BLRDA))>IOSL
DO XHDR
DO SPHDR
IF $DATA(DIRUT)
QUIT
+7 ;p1039 ,PHDR Q:$G(DIRUT)
IF $Y+2>IOSL
DO XHDR
DO SPHDR
IF $DATA(DIRUT)
QUIT
+8 WRITE !!!,"TEST NAME: "_$PIECE(^TMP("BLRRL",$JOB,BLRDA,"TCNM"),U,2)_" ("_$PIECE(^TMP("BLRRL",$JOB,BLRDA,"TCNM"),U)_")"
+9 WRITE ?45,"SAMPLE: "_BLRSAMP
+10 WRITE !,"SOURCE: "_^TMP("BLRRL",$JOB,BLRDA,"SRC")
+11 WRITE ?45,"ACCESSION (Lab Ref#): "_^TMP("BLRRL",$JOB,BLRDA,"UID")
+12 WRITE !,?45,"URGENCY: "_BLRURG
+13 WRITE !,"LAB PROCESSING INSTR: "_$$LABINST(BLRDA,^TMP("BLRRL",$JOB,BLRDA,"SAMP"))
+14 IF $ORDER(^TMP("BLRRL",$JOB,BLRDA,"COMMENT",0))
Begin DoDot:2
+15 WRITE !!,"ORDER ENTRY QUESTIONS: "
+16 NEW BLRODA
+17 SET BLRODA=0
FOR
SET BLRODA=$ORDER(^TMP("BLRRL",$JOB,BLRDA,"COMMENT",BLRODA))
IF 'BLRODA
QUIT
Begin DoDot:3
+18 SET ORDC=$GET(^TMP("BLRRL",$JOB,BLRDA,"COMMENT",BLRODA))
+19 ;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
+20 IF $ORDER(LRTCOM(BLRDA,0))
Begin DoDot:2
+21 WRITE !!,"COMMENTS: "
+22 NEW BLRUDA
+23 SET BLRUDA=0
FOR
SET BLRUDA=$ORDER(LRTCOM(BLRDA,BLRUDA))
IF 'BLRUDA
QUIT
Begin DoDot:3
+24 ;filter
IF $GET(LRTCOM(BLRDA,BLRUDA))["For Test"
QUIT
+25 WRITE !,?5,$TRANSLATE($GET(LRTCOM(BLRDA,BLRUDA)),"~")
End DoDot:3
End DoDot:2
+26 DO DX(BLRDA)
+27 DO INS(BLRDA)
End DoDot:1
+28 WRITE !!
+29 QUIT
+30 ;
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 WRITE !,"Diagnosis: ",?25,"DX Description: "
+5 NEW DXDA,ORD,ORDI,DXDATA,DXSTR,UID
+6 SET UID=^TMP("BLRRL",$JOB,BLRDA,"UID")
+7 IF '$GET(UID)
SET UID=LRUID
+8 SET ORD=$ORDER(^BLRRLO("ACC",UID,0))
+9 SET ORDI=0
FOR
SET ORDI=$ORDER(^BLRRLO(ORD,1,ORDI))
IF 'ORDI
QUIT
Begin DoDot:1
+10 SET DXDATA=$PIECE($GET(^BLRRLO(ORD,1,ORDI,0)),U)
+11 SET DXSTR=$SELECT($DATA(^ICDS(0)):$$ICDDX^ICDEX(DXDATA,DT),1:$$ICDDX^ICDCODE(DXDATA,DT))
+12 WRITE !,$PIECE(DXSTR,U,2),?25,$PIECE(DXSTR,U,4)
End DoDot:1
+13 QUIT
+14 ;
INS(BDA) ;-- if insurance info print insurance
+1 IF '$GET(BDA)
QUIT
+2 IF '$DATA(^TMP("BLRRL",$JOB,"COMMON","INSE"))
QUIT
+3 WRITE !!,"INSURANCE"
+4 WRITE !,"Insurer ID: "_$GET(^TMP("BLRRL",$JOB,BDA,"INSID")),?40,"Insured Name: "_$EXTRACT($GET(^TMP("BLRRL",$JOB,BDA,"INSNOIE")),1,26)
+5 WRITE ?68,"Rel: "_$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 NEW I
+14 ;write hyphens to separate
FOR I=1:1:80
WRITE "-"
+15 QUIT
+16 ;
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 SET BLRHDC=8
+2 SET BLRPDC=7
+3 SET BLRWTC=8
+4 NEW BLRNDA,BLRNCNT,BLRNIEN,BLRCMCNT,BLRNACC,BLRDXCNT
+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=(BLRWTC*BLRNACC)
+12 SET BLRNCNT=(BLRHDC+BLRPDC+BLRNACC+(+$GET(BLRCMCNT)))
+13 NEW BLRINSCN,BLRSECC
+14 IF $DATA(^TMP("BLRRL",$JOB,"COMMON","INSE"))
Begin DoDot:1
+15 SET BLRINSCN=11
End DoDot:1
+16 SET BLRNCNT=BLRNCNT+(+$GET(BLRDXCNT)+(+$GET(BLRINSCN)))
+17 SET BLRPG=(BLRNCNT/(IOSL-2))
+18 SET BLRPGP=$PIECE(BLRPG,".")
+19 SET BLRPGE=$PIECE(BLRPG,".",2)
+20 IF BLRPGE>0
SET BLRPGP=BLRPGP+1
+21 QUIT BLRPGP
+22 ;
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*1031
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 KILL ^TMP("BLRRL",$JOB)
+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
+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 ;go to the Quest Manifest
IF $PIECE($GET(^BLRRL($PIECE($GET(^BLRSITE($SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U),0)),U)["LABCORP"
Begin DoDot:1
+4 DO REP^BLRSHPML
End DoDot:1
QUIT
+5 DO ASKS
+6 IF '$GET(BLRRIEN)
KILL BLRRIEN
QUIT
+7 DO RPRT(BLRRIEN)
+8 DO ^%ZISC
+9 KILL BLRRIEN
+10 QUIT
+11 ;
ASKS ;-- get the ien of the entry
+1 KILL DIR
+2 SET DIR(0)="P^9009026.2"
SET DIR("A")="Reprint for which Accession Number (UID) "
+3 DO ^DIR
+4 IF $DATA(DIRUT)
QUIT
+5 SET BLRRIEN=+Y
+6 QUIT
+7 ;
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 ;
+7 ;
+8 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
TOSCREEN ; EP - Reprint to the screen
+1 NEW BLRDA,BLRRIEN,RIEN
+2 DO ASKS
+3 IF '$GET(BLRRIEN)
KILL BLRRIEN
QUIT
+4 ;
+5 DO ^XBCLS
+6 SET BLRDA=0
FOR
SET BLRDA=$ORDER(^BLRSHPM(BLRRIEN,11,BLRDA))
IF BLRDA<1
QUIT
Begin DoDot:1
+7 WRITE !,$GET(^BLRSHPM(BLRRIEN,11,BLRDA,0))
End DoDot:1
+8 ;
+9 DO PRESSKEY^BLRGMENU(9)
+10 QUIT
+11 ; ----- END IHS/MSC/MKK - LR*5.2*1034
