BLRSHPMQ ;cmi/anch/maw - BLR Reference Lab Shipping Manifest Quest 11:46 ;JUL 06, 2010 3:14 PM
;;5.2;IHS LABORATORY;**1027,1028,1030,1031**;NOV 01, 1997
;
;
;
;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/22/2008 cmi/anch/maw added routine for Quest specific modifications
;
;
PRT ;EP - print shipping manifest
Q:'$D(^TMP("BLRRL",$J)) ;don't print shipping manifest if no data
W !!,"Now printing shipping manifest for this accession"
D ^%ZISC ;maw 3/28/2006
U $$DEV
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
D ^%ZISC ;maw 3/28/2006
D STOR(.BLRSHIEN,^TMP("BLRRL",$J,"COMMON","UID")) ;store the shipping manifest as well as print
D EOJ
Q
;
ALL ;-- run all sub routines after initial vars
D XHDR
;D PHDR
D WRTS
;D DX
;D INS
Q
;
STOR(BLRSHIEN,ACC) ;-- this will store the shipping manifest
;accession number gets passed in
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^BLRSHPMQ","^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
;
PHDR ;-- write the common stuff to the device
W !
F BLRI=1:1:80 W "="
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
;
WRTS ;-- write the output to the device
N BLRDA,BLRIEN
;cmi/anch/maw 7/23/2007 here is where you could sort by order if BLRDA was the order num
S BLRDA=0 F S BLRDA=$O(^TMP("BLRRL",$J,BLRDA)) Q:BLRDA="" D
. Q:BLRDA="COMMON"
. D PHDR
. D INS(BLRDA) ;8/25/2008 moved insurance call here
. S BLRSAMP=$P($G(^LAB(62,^TMP("BLRRL",$J,BLRDA,"SAMP"),0)),U)
. I $Y+($$CHKOEQ(BLRDA))>IOSL D XHDR,PHDR,INS(BLRDA) Q:$G(DIRUT)
. W !!,"ACCESSION (Lab Ref#): "_^TMP("BLRRL",$J,BLRDA,"UID")
. 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,"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),?50,$P(ORDC,U,3) ;cmi/maw 12/12/2007 orig line
... 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)
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))
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=6
S BLRWTC=9
N BLRNDA,BLRNCNT,BLRNIEN
S BLRNDA=0,BLRNCNT=0
F S BLRNDA=$O(^TMP("BLRRL",$J,BLRNDA)) Q:'BLRNDA D
. S BLRNIEN=0 F S BLRNIEN=$O(^TMP("BLRRL",$J,BLRNDA,"COMMENT",BLRNIEN)) Q:'BLRNIEN D
.. S BLRNCNT=BLRNCNT+1
S BLRNCNT=(BLRHDC+BLRPDC+BLRWTC+BLRNCNT)
S BLRPG=(BLRNCNT/(IOSL-2))
S BLRPGP=$P(BLRPG,".")
S BLRPGE=$P(BLRPG,".",2)
I BLRPGE>0 S BLRPGP=BLRPGP+1
Q BLRPGP
;
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: 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
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 !
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
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
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
;
BLRSHPMQ ;cmi/anch/maw - BLR Reference Lab Shipping Manifest Quest 11:46 ;JUL 06, 2010 3:14 PM
+1 ;;5.2;IHS LABORATORY;**1027,1028,1030,1031**;NOV 01, 1997
+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/22/2008 cmi/anch/maw added routine for Quest specific modifications
+15 ;
+16 ;
PRT ;EP - print shipping manifest
+1 ;don't print shipping manifest if no data
IF '$DATA(^TMP("BLRRL",$JOB))
QUIT
+2 WRITE !!,"Now printing shipping manifest for this accession"
+3 ;maw 3/28/2006
DO ^%ZISC
+4 USE $$DEV
+5 SET BLRFAC=$$GET1^DIQ(9999999.06,$SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),.01)
+6 SET BLRSTR=$$GET1^DIQ(9999999.06,$SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),.14)
+7 SET BLRCTY=$$GET1^DIQ(9999999.06,$SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),.15)
+8 SET BLRST=$$GET1^DIQ(9999999.06,$SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),.16)
+9 SET BLRZIP=$$GET1^DIQ(9999999.06,$SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),.17)
+10 NEW BLRPH
+11 SET BLRPH=$$GET1^DIQ(9999999.06,$SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),.13)
+12 SET BLRCHT=$$HRN^AUPNPAT(^TMP("BLRRL",$JOB,"COMMON","PAT"),DUZ(2))
+13 SET BLRURG=$PIECE($GET(^LAB(62.05,^TMP("BLRRL",$JOB,"COMMON","URG"),0)),U)
+14 SET BLRPGC=$$GETPG
+15 SET BLRNPG=1
+16 DO ALL
+17 ;maw 3/28/2006
DO ^%ZISC
+18 ;store the shipping manifest as well as print
DO STOR(.BLRSHIEN,^TMP("BLRRL",$JOB,"COMMON","UID"))
+19 DO EOJ
+20 QUIT
+21 ;
ALL ;-- run all sub routines after initial vars
+1 DO XHDR
+2 ;D PHDR
+3 DO WRTS
+4 ;D DX
+5 ;D INS
+6 QUIT
+7 ;
STOR(BLRSHIEN,ACC) ;-- this will store the shipping manifest
+1 ;accession number gets passed in
+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^BLRSHPMQ","^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 ;
PHDR ;-- write the common stuff to the device
+1 WRITE !
+2 FOR BLRI=1:1:80
WRITE "="
+3 WRITE !!,"ORDER (Control): "_^TMP("BLRRL",$JOB,"COMMON","ORD")
+4 WRITE ?30,"ORDER DATE: "_$$FMTE^XLFDT(^TMP("BLRRL",$JOB,"COMMON","ODT"))
+5 WRITE ?60,"MID: "_$$MID(+$GET(BHLMSG))
+6 WRITE !,"PATIENT: "_$PIECE($GET(^DPT(^TMP("BLRRL",$JOB,"COMMON","PAT"),0)),U)
+7 ;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:"")
+8 ; 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
+9 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
+10 ; DOB must be in human-readable format
+11 WRITE !,"SEX: "_$GET(SEX),?10,"DOB: "_$SELECT(+$GET(DOB)>1950101:$$FMTE^XLFDT(DOB),1:$GET(DOB))
+12 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")
+13 ; ----- END IHS/MSC/MKK - LR*5.2*1031
+14 ;W !,"LOCATION: "_^TMP("BLRRL",$J,"COMMON","LOC"),?55,"Bill Type: Client" cmi/maw 10/31/07 orig line
+15 WRITE !,"LOCATION: "_^TMP("BLRRL",$JOB,"COMMON","LOC")
+16 ;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")
+17 ;cmi/maw 2/29/2008 added UPIN/NPI print based on site parameter
+18 WRITE !,"PRACTITIONER: "_$PIECE(^TMP("BLRRL",$JOB,"COMMON","ORDPNM"),U)_", "_$PIECE(^TMP("BLRRL",$JOB,"COMMON","ORDPNM"),U,2)
+19 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")))
+20 WRITE !,"LAB ARRIVAL (COLLECTION DATE/TIME): "_$$FMTE^XLFDT(^TMP("BLRRL",$JOB,"COMMON","CDT"))
+21 QUIT
+22 ;
WRTS ;-- write the output to the device
+1 NEW BLRDA,BLRIEN
+2 ;cmi/anch/maw 7/23/2007 here is where you could sort by order if BLRDA was the order num
+3 SET BLRDA=0
FOR
SET BLRDA=$ORDER(^TMP("BLRRL",$JOB,BLRDA))
IF BLRDA=""
QUIT
Begin DoDot:1
+4 IF BLRDA="COMMON"
QUIT
+5 DO PHDR
+6 ;8/25/2008 moved insurance call here
DO INS(BLRDA)
+7 SET BLRSAMP=$PIECE($GET(^LAB(62,^TMP("BLRRL",$JOB,BLRDA,"SAMP"),0)),U)
+8 IF $Y+($$CHKOEQ(BLRDA))>IOSL
DO XHDR
DO PHDR
DO INS(BLRDA)
IF $GET(DIRUT)
QUIT
+9 WRITE !!,"ACCESSION (Lab Ref#): "_^TMP("BLRRL",$JOB,BLRDA,"UID")
+10 WRITE !,"TEST NAME: "_$PIECE(^TMP("BLRRL",$JOB,BLRDA,"TCNM"),U,2)_" ("_$PIECE(^TMP("BLRRL",$JOB,BLRDA,"TCNM"),U)_")"
+11 WRITE ?45,"SAMPLE: "_BLRSAMP
+12 WRITE !,"SOURCE: "_^TMP("BLRRL",$JOB,BLRDA,"SRC")
+13 WRITE ?45,"URGENCY: "_BLRURG
+14 WRITE !,"LAB PROCESSING INSTR: "_$$LABINST(BLRDA,^TMP("BLRRL",$JOB,BLRDA,"SAMP"))
+15 IF $ORDER(^TMP("BLRRL",$JOB,BLRDA,"COMMENT",0))
Begin DoDot:2
+16 WRITE !!,"ORDER ENTRY QUESTIONS: "
+17 NEW BLRODA
+18 SET BLRODA=0
FOR
SET BLRODA=$ORDER(^TMP("BLRRL",$JOB,BLRDA,"COMMENT",BLRODA))
IF 'BLRODA
QUIT
Begin DoDot:3
+19 SET ORDC=$GET(^TMP("BLRRL",$JOB,BLRDA,"COMMENT",BLRODA))
+20 ;W !,?5,$P(ORDC,U,2),?50,$P(ORDC,U,3) ;cmi/maw 12/12/2007 orig line
+21 ;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
+22 IF $ORDER(LRTCOM(BLRDA,0))
Begin DoDot:2
+23 WRITE !!,"COMMENTS: "
+24 NEW BLRUDA
+25 SET BLRUDA=0
FOR
SET BLRUDA=$ORDER(LRTCOM(BLRDA,BLRUDA))
IF 'BLRUDA
QUIT
Begin DoDot:3
+26 ;filter
IF $GET(LRTCOM(BLRDA,BLRUDA))["For Test"
QUIT
+27 WRITE !,?5,$TRANSLATE($GET(LRTCOM(BLRDA,BLRUDA)),"~")
End DoDot:3
End DoDot:2
+28 DO DX(BLRDA)
End DoDot:1
+29 WRITE !!
+30 QUIT
+31 ;
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 NEW DXDA
+7 SET DXDA=0
FOR
SET DXDA=$ORDER(^TMP("BLRRL",$JOB,BDA,"DX",DXDA))
IF 'DXDA
QUIT
Begin DoDot:1
+8 WRITE !,$GET(^TMP("BLRRL",$JOB,BDA,"DX",DXDA)),?25,$GET(^TMP("BLRRL",$JOB,BDA,"DXE",DXDA))
End DoDot:1
+9 QUIT
+10 ;
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=6
+3 SET BLRWTC=9
+4 NEW BLRNDA,BLRNCNT,BLRNIEN
+5 SET BLRNDA=0
SET BLRNCNT=0
+6 FOR
SET BLRNDA=$ORDER(^TMP("BLRRL",$JOB,BLRNDA))
IF 'BLRNDA
QUIT
Begin DoDot:1
+7 SET BLRNIEN=0
FOR
SET BLRNIEN=$ORDER(^TMP("BLRRL",$JOB,BLRNDA,"COMMENT",BLRNIEN))
IF 'BLRNIEN
QUIT
Begin DoDot:2
+8 SET BLRNCNT=BLRNCNT+1
End DoDot:2
End DoDot:1
+9 SET BLRNCNT=(BLRHDC+BLRPDC+BLRWTC+BLRNCNT)
+10 SET BLRPG=(BLRNCNT/(IOSL-2))
+11 SET BLRPGP=$PIECE(BLRPG,".")
+12 SET BLRPGE=$PIECE(BLRPG,".",2)
+13 IF BLRPGE>0
SET BLRPGP=BLRPGP+1
+14 QUIT BLRPGP
+15 ;
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: 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 WRITE !,?28,"INDIAN HEALTH SERVICE EREQ",?65,"PAGE: "_BLRNPG_" of "_BLRPGC
+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 ;cmi/flag/maw increment current page
SET BLRNPG=BLRNPG+1
+9 QUIT
+10 ;
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
+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 DO ASKS
+2 IF '$GET(BLRRIEN)
KILL BLRRIEN
QUIT
+3 DO RPRT(BLRRIEN)
+4 DO ^%ZISC
+5 KILL BLRRIEN
+6 QUIT
+7 ;
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 ;
