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

BLRSHPMQ.m

Go to the documentation of this file. 
  1. 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
  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/22/2008 cmi/anch/maw added routine for Quest specific modifications
  1.  ;
  1.  ;
  1. PRT ;EP - print shipping manifest
  1.  Q:'$D(^TMP("BLRRL",$J))  ;don't print shipping manifest if no data
  1.  W !!,"Now printing shipping manifest for this accession"
  1.  D ^%ZISC  ;maw 3/28/2006
  1.  U $$DEV
  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.  D ^%ZISC  ;maw 3/28/2006
  1.  D STOR(.BLRSHIEN,^TMP("BLRRL",$J,"COMMON","UID"))  ;store the shipping manifest as well as print
  1.  D EOJ
  1.  Q
  1.  ;
  1. ALL ;-- run all sub routines after initial vars
  1.  D XHDR
  1.  ;D PHDR
  1.  D WRTS
  1.  ;D DX
  1.  ;D INS
  1.  Q
  1.  ;
  1. STOR(BLRSHIEN,ACC) ;-- this will store the shipping manifest
  1.  ;accession number gets passed in
  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^BLRSHPMQ","^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. PHDR ;-- write the common stuff to the device
  1.  W !
  1.  F BLRI=1:1:80 W "="
  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 (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
  1.  ; 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
  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.  ;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.  ;cmi/anch/maw 7/23/2007 here is where you could sort by order if BLRDA was the order num
  1.  S BLRDA=0 F  S BLRDA=$O(^TMP("BLRRL",$J,BLRDA)) Q:BLRDA=""  D
  1.  . Q:BLRDA="COMMON"
  1.  . D PHDR
  1.  . D INS(BLRDA)  ;8/25/2008 moved insurance call here
  1.  . S BLRSAMP=$P($G(^LAB(62,^TMP("BLRRL",$J,BLRDA,"SAMP"),0)),U)
  1.  . I $Y+($$CHKOEQ(BLRDA))>IOSL D XHDR,PHDR,INS(BLRDA) Q:$G(DIRUT)
  1.  . W !!,"ACCESSION (Lab Ref#): "_^TMP("BLRRL",$J,BLRDA,"UID")
  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,"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),?50,$P(ORDC,U,3)  ;cmi/maw 12/12/2007 orig line
  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.  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.  Q
  1.  ;
  1. INS(BDA) ;-- if insurance info print insurance
  1.  Q:'$G(BDA)
  1.  Q:'$D(^TMP("BLRRL",$J,"COMMON","INSE"))
  1.  W !!,"INSURANCE"
  1.  W !,"Insurer ID: "_$G(^TMP("BLRRL",$J,BDA,"INSID")),?40,"Insured Name: "_$E($G(^TMP("BLRRL",$J,BDA,"INSNOIE")),1,26)
  1.  W ?68,"Rel: "_$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.  N I
  1.  F I=1:1:80 W "-"  ;write hyphens to separate
  1.  Q
  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=6
  1.  S BLRWTC=9
  1.  N BLRNDA,BLRNCNT,BLRNIEN
  1.  S BLRNDA=0,BLRNCNT=0
  1.  F  S BLRNDA=$O(^TMP("BLRRL",$J,BLRNDA)) Q:'BLRNDA  D
  1.  . S BLRNIEN=0 F  S BLRNIEN=$O(^TMP("BLRRL",$J,BLRNDA,"COMMENT",BLRNIEN)) Q:'BLRNIEN  D
  1.  .. S BLRNCNT=BLRNCNT+1
  1.  S BLRNCNT=(BLRHDC+BLRPDC+BLRWTC+BLRNCNT)
  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. 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*1031: 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
  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.  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
  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.  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.  ;