BLRRLMV ; cmi/anch/maw - BLR View/Refile Raw Reference Lab Messages ; 13-Oct-2017 14:04 ; MAW
;;5.2;LR;**1021,1030,1033,1035,1041**;NOV 1, 1997;Build 23
;;1.0;BLR REFERENCE LAB;;MAR 14, 2005
;
;
;
;this routine will allow the user to verify reference lab results
;before passing them on to PCC
;
MAIN ;EP - this is the main routine driver
S BLRMF=$$ASK
I $G(BLRMF)="F" D Q
. S BLRRF=$$ASKF
. I $G(BLRRF)]"" D LOOP
. D EOJ
I $G(BLRMF)="M" D
. S BLRMSG=$$ASKM
. I $G(BLRMSG) D SM(BLRMSG)
D EOJ
Q
;
ASK() ;-- ask to look by message number or file
S DIR(0)="S^M:Message Number;F:File",DIR("A")="Select by Message Number or File Name "
D ^DIR
K DIR
Q $G(Y)
;
ASKF() ;-- ask file
S DIR(0)="P^9009026.1",DIR("A")="Which Reference Lab Import File Do You Want To View "
D ^DIR
K DIR
Q +$G(Y)
;
ASKM() ;-- ask message number
S DIR(0)="N",DIR("A")="Which Message Would You Like to View/Refile "
D ^DIR
K DIR
Q +$G(Y)
;
LEDI ;EP - main LEDI driver
;I '$$EDITRFL D EDHL Q
N BLRAN,BLRIN,BLRYN
S BLRAN=$$ASKA
I $G(BLRAN) S BLRIN=$$ACCLOOK(.BLRD,BLRAN)
I '$G(BLRIN) D EOJ Q
S BLRYN=$$RFL(BLRIN)
I $G(BLRYN) D
. ;N BLRMA
. S BLRMA=$O(^HLMA("B",$G(BLRD(BLRYN)),0))
. Q:'BLRMA
. D EN^XBNEW("CALLHL^BLRRLMV","BLRMA")
. ;D REPROC^HLUTIL(BLRMA,"D ORU^LA7VHL")
D EOJ
Q
;
CALLHL ;call the hl refiler
N ORIGDUZ
S ORIGDUZ=DUZ
D REPROC^HLUTIL(BLRMA,"D ORU^LA7VHL")
D DUZ^XUP(ORIGDUZ)
Q
;
EDITRFL() ;-- edit or just refile
K DIR
S DIR(0)="S^E:Edit and Refile Message;R:Refile Message"
D ^DIR
Q:$D(DIRUT) 0
I $G(Y)="E" Q 0
Q 1
;
ACCLOOK(BLRD,ACC) ;lets look up the accession number in HL(772
N BLRDA,BLRIEN,BLRMT,BLRI,BLRM,BLRCN
S BLRMT=0
S BLRCN=0
S BLRDA=0 F S BLRDA=$O(^HL(772,BLRDA)) Q:'BLRDA!($G(BLRMT)) D
. S BLRIEN=0 F S BLRIEN=$O(^HL(772,BLRDA,"IN",BLRIEN)) Q:'BLRIEN!($G(BLRMT)) D
.. I $G(^HL(772,BLRDA,"IN",BLRIEN,0))[ACC,$$CHKMSG(BLRDA) D
... S BLRCN=BLRCN+1
... S BLRD(BLRCN)=BLRDA
... S BLRD=BLRDA,BLRI=BLRIEN ;,BLRMT=1
I '$D(BLRD) W !,"Could not find an entry to refile" Q ""
N BLRIDA,BLRDD
S BLRIDA=0 F S BLRIDA=$O(BLRD(BLRIDA)) Q:'BLRIDA D
. S BLRDD=$G(BLRD(BLRIDA))
. W !!,"Entry #"_BLRIDA,!
. D WRT(BLRDD)
;S BLRM=$O(^HLMA("B",BLRD,0))
;Q $G(BLRM),!
Q $G(BLRCN)
;
RFL(IN) ;-- ask if they want to refile
;S DIR(0)="Y",DIR("A")="Is this the entry you want to refile",DIR("B")="Y"
;D ^DIR
;Q +$G(Y)
;
K DIR
S DIR(0)="N^1:"_IN,DIR("A")="Refile which entry"
D ^DIR
Q +$G(Y)
;
ASKA() ;-- ask the accession number
K DIR
S DIR(0)="N",DIR("A")="Which Accession/Order # Would You Like to View/Refile "
D ^DIR
K DIR
Q +$G(Y)
;
CHKMSG(M) ;-- check to see if this is an ORU R01 message
N MI
S MI=$O(^HLMA("B",M,0))
I 'MI Q 0
I $$GET1^DIQ(779.001,$P($G(^HLMA(MI,0)),U,14),.01)="R01" Q 1
Q 0
WRT(RD) ;-- lets call DIQ to display the entry
N BLRI
S BLRI=0 F S BLRI=$O(^HL(772,RD,"IN",BLRI)) Q:'BLRI D
. W !,$G(^HL(772,RD,"IN",BLRI,0))
Q
;
LOOP ;-- loop the xref and call VER
I $O(^BLRRLG("B",0))="" D Q
. W !,"No Files to View"
S DIC="^INTHU("
S BLRVDA=0 F S BLRVDA=$O(^BLRRLG(BLRRF,1,BLRVDA)) Q:'BLRVDA!$G(BLRVQ) D
. Q:$G(BLRVQ)
. W @IOF
. S (DA,BLRUIF)=$G(^BLRRLG(BLRRF,1,BLRVDA,0))
. I '$G(^INTHU(BLRUIF,0)) D Q
.. W !!,"GIS HL7 Message "_BLRUIF_" has already been purged, cannot display"
. D DIQ^BLRLMR(DIC,DA)
W !!,"No More Messages in Batch, Exiting"
H 2
Q
;
SM(BLRUIF) ;-- view the message
I '$D(^INTHU(BLRUIF)) D Q
. W !!,"GIS HL7 Message "_BLRUIF_" has already been purged, cannot display"
S DIC="^INTHU("
Q:$G(BLRVQ)
W @IOF
S (DA,BLRUIF)=BLRUIF
D DIQ^BLRLMR(DIC,DA)
Q
;
REF(UIF) ;-- mark entry as verified
S ^INLHSCH(0,$H,UIF)=""
Q
;cmi/flag/maw 4/8/2004 the following is not used anymore
S BLRRL=$P($G(^BLRSITE(DUZ(2),"RL")),U)
Q:'$G(BLRRL)
S BLRRLE=$P($G(^BLRRL(BLRRL,0)),U)
S BLRSCR=$O(^INRHS("B","Generated: HL IHS LAB R01 "_BLRRLE_" IN-I",0))
Q:'$G(BLRSCR)
S BLRRUN="S BLRRFL=$$^IS"_$$ZERO(BLRSCR)_BLRSCR_"("_UIF_")"
X BLRRUN
Q
;
EOJ ;-- kill variables
D JOB^BLRPARAM
D EN^XBVK("BLR")
Q
;
ZERO(SCR) ;-- find out how many zeros need to be installed
I $L(BLRSCR)=1 Q "0000"
I $L(BLRSCR)=2 Q "000"
I $L(BLRSCR)=3 Q "00"
I $L(BLRSCR)=4 Q "0"
Q "0"
;
EDHL ;-- lets insert the accession number if not there by finding the patient and order code
N BLRP,BLRON,BLRCDTBLRAC,BLRIN,BLRYN,BLRY,BLRM
S BLRP=$$ASKP
Q:'$G(BLRP)
S BLRON=$$ASKO
Q:'$G(BLRON)
S BLRCDT=$$ASKCDT
Q:'$G(BLRCDT)
S BLRCDT=$$FMTHL7^XLFDT(BLRCDT)
I $G(BLRP),$G(BLRON),$G(BLRCDT) S BLRIN=$$MSGLOOK(.BLRD,BLRP,BLRON,BLRCDT)
I '$G(BLRIN) D EOJ Q
;need to change this below so BLRY is the actual message number at this point
S BLRY=$$CMSG(BLRIN)
Q:'$G(BLRY)
S BLRM=$G(BLRD(BLRY))
Q:'$G(BLRM)
D SETOBR(BLRM)
Q:'$D(BLROBR)
D ADDACC(.BLROBR,BLRM)
D UPACC(.BLROBR,BLRM)
S BLRYN=$$ERFL(BLRM)
I $G(BLRYN) D
. N BLRMA
. S BLRMA=$O(^HLMA("B",BLRM,0))
. Q:'BLRMA
. D REPROC^HLUTIL(BLRMA,"D ORU^LA7VHL")
D EOJ
Q
;
ASKP() ;-- ask the patient chart
K DIR
S DIR(0)="N",DIR("A")="What is the patient chart number to find "
D ^DIR
K DIR
Q +$G(Y)
;
ASKO() ;-- ask the order code
K DIR
S DIR(0)="F",DIR("A")="What is the order code to find "
D ^DIR
K DIR
Q +$G(Y)
;
ASKCDT() ;-- ask the collection date
K %DT
S %DT="AE",%DT("A")="What is the collection date: "
D ^%DT
I Y=-1 Q 0
Q +Y
Q
;
ASKAC() ;-- ask the accession number
K DIR
S DIR(0)="N",DIR("A")="What is the accession number to insert "
D ^DIR
K DIR
Q +$G(Y)
;
MSGLOOK(BLRD,PT,ON,CDT) ;lets look up the accession number in HL(772
N BLRDA,BLRIEN,BLRMT,BLRI,BLRM,BLRCN,BLRMT
S BLRCN=0
S BLRDA=0 F S BLRDA=$O(^HL(772,BLRDA)) Q:'BLRDA D
. S BLRMT=0
. S BLRIEN=0 F S BLRIEN=$O(^HL(772,BLRDA,"IN",BLRIEN)) Q:'BLRIEN D
.. I $P($G(^HL(772,BLRDA,"IN",BLRIEN,0)),"|")="PID",$P($G(^HL(772,BLRDA,"IN",BLRIEN,0)),"|",4)=PT,$$CHKMSG(BLRDA) S BLRMT=1
.. Q:'$G(BLRMT)
.. I $P($G(^HL(772,BLRDA,"IN",BLRIEN,0)),"|")="OBR",$P($P($G(^HL(772,BLRDA,"IN",BLRIEN,0)),"|",5),"^",4)=ON,$E($P($G(^HL(772,BLRDA,"IN",BLRIEN,0)),"|",8),1,8)=CDT,$$CHKMSG(BLRDA) S BLRMT=2
.. Q:$G(BLRMT)'=2
.. S BLRCN=BLRCN+1
.. S BLRD(BLRCN)=BLRDA
.. S BLRD=BLRDA,BLRI=BLRIEN ;,BLRMT=1
.. K BLRMT
I '$D(BLRD) W !,"Could not find a matching entry" Q ""
N BLRIDA,BLRDD
S BLRIDA=0 F S BLRIDA=$O(BLRD(BLRIDA)) Q:'BLRIDA D
. S BLRDD=$G(BLRD(BLRIDA))
. W !!,"Entry #"_BLRIDA,!
. D WRT(BLRDD)
;S BLRM=$O(^HLMA("B",BLRD,0))
;Q $G(BLRM),!
Q $G(BLRCN)
;
SETOBR(MSG) ;-- loop through the message and get the OBR and test for editing
N MDA,CODE,DESC
S MDA=0 F S MDA=$O(^HL(772,MSG,"IN",MDA)) Q:'MDA D
. I $P($G(^HL(772,MSG,"IN",MDA,0)),"|")="OBR" D
.. S CODE=$P($P($G(^HL(772,MSG,"IN",MDA,0)),"|",5),"^",4)
.. S DESC=$P($P($G(^HL(772,MSG,"IN",MDA,0)),"|",5),"^",5)
.. S BLROBR(MSG,MDA)=CODE_U_DESC
Q
;
ERFL(RY) ;-- ask if they want to refile
W !
D WRT(RY)
K DIR
S DIR(0)="Y",DIR("A")="Ready to Refile"
D ^DIR
Q +$G(Y)
;
CMSG(IN) ;-- ask if they want to refile
K DIR
S DIR(0)="N^1:"_IN,DIR("A")="Which message is the correct one to edit"
D ^DIR
Q +$G(Y)
;
ADDACC(OBR,RY) ;-- lets add the accession to the obr
N RDA,CD,DS,SAME
S SAME=$$SAMEACC
Q:SAME=-1
I SAME D Q
. S ACC=$$ACC("","",1)
. S RDA=0 F S RDA=$O(OBR(RY,RDA)) Q:'RDA D
.. S $P(OBR(RY,RDA),U,3)=ACC
S RDA=0 F S RDA=$O(OBR(RY,RDA)) Q:'RDA D
. S CD=$P(OBR(RY,RDA),U)
. S DS=$P(OBR(RY,RDA),U,2)
. S ACC=$$ACC(CD,DS,0)
. Q:'$G(ACC)
. S $P(OBR(RY,RDA),U,3)=ACC
Q
;
SAMEACC() ;-- same accession number for all tests
K DIR
S DIR(0)="Y",DIR("A")="Same accession number for all tests"
D ^DIR
Q:$D(DIRUT) -1
Q +$G(Y)
;
ACC(C,D,T) ;-- lets get the accession number to file
K DIR,PRM
S DIR(0)="N"
S PRM=$S(T:"Accession number for all tests",1:"Accession number for test ("_C_") "_D)
S DIR("A")=PRM
D ^DIR
Q +$G(Y)
;
UPACC(OBR,RY) ;-- update the message with accessions
N UDA,AC
S UDA=0 F S UDA=$O(OBR(RY,UDA)) Q:'UDA D
. S AC=$P($G(OBR(RY,UDA)),U,3)
. S $P(^HL(772,RY,"IN",UDA,0),"|",3)=AC
Q
;
BLRRLMV ; cmi/anch/maw - BLR View/Refile Raw Reference Lab Messages ; 13-Oct-2017 14:04 ; MAW
+1 ;;5.2;LR;**1021,1030,1033,1035,1041**;NOV 1, 1997;Build 23
+2 ;;1.0;BLR REFERENCE LAB;;MAR 14, 2005
+3 ;
+4 ;
+5 ;
+6 ;this routine will allow the user to verify reference lab results
+7 ;before passing them on to PCC
+8 ;
MAIN ;EP - this is the main routine driver
+1 SET BLRMF=$$ASK
+2 IF $GET(BLRMF)="F"
Begin DoDot:1
+3 SET BLRRF=$$ASKF
+4 IF $GET(BLRRF)]""
DO LOOP
+5 DO EOJ
End DoDot:1
QUIT
+6 IF $GET(BLRMF)="M"
Begin DoDot:1
+7 SET BLRMSG=$$ASKM
+8 IF $GET(BLRMSG)
DO SM(BLRMSG)
End DoDot:1
+9 DO EOJ
+10 QUIT
+11 ;
ASK() ;-- ask to look by message number or file
+1 SET DIR(0)="S^M:Message Number;F:File"
SET DIR("A")="Select by Message Number or File Name "
+2 DO ^DIR
+3 KILL DIR
+4 QUIT $GET(Y)
+5 ;
ASKF() ;-- ask file
+1 SET DIR(0)="P^9009026.1"
SET DIR("A")="Which Reference Lab Import File Do You Want To View "
+2 DO ^DIR
+3 KILL DIR
+4 QUIT +$GET(Y)
+5 ;
ASKM() ;-- ask message number
+1 SET DIR(0)="N"
SET DIR("A")="Which Message Would You Like to View/Refile "
+2 DO ^DIR
+3 KILL DIR
+4 QUIT +$GET(Y)
+5 ;
LEDI ;EP - main LEDI driver
+1 ;I '$$EDITRFL D EDHL Q
+2 NEW BLRAN,BLRIN,BLRYN
+3 SET BLRAN=$$ASKA
+4 IF $GET(BLRAN)
SET BLRIN=$$ACCLOOK(.BLRD,BLRAN)
+5 IF '$GET(BLRIN)
DO EOJ
QUIT
+6 SET BLRYN=$$RFL(BLRIN)
+7 IF $GET(BLRYN)
Begin DoDot:1
+8 ;N BLRMA
+9 SET BLRMA=$ORDER(^HLMA("B",$GET(BLRD(BLRYN)),0))
+10 IF 'BLRMA
QUIT
+11 DO EN^XBNEW("CALLHL^BLRRLMV","BLRMA")
+12 ;D REPROC^HLUTIL(BLRMA,"D ORU^LA7VHL")
End DoDot:1
+13 DO EOJ
+14 QUIT
+15 ;
CALLHL ;call the hl refiler
+1 NEW ORIGDUZ
+2 SET ORIGDUZ=DUZ
+3 DO REPROC^HLUTIL(BLRMA,"D ORU^LA7VHL")
+4 DO DUZ^XUP(ORIGDUZ)
+5 QUIT
+6 ;
EDITRFL() ;-- edit or just refile
+1 KILL DIR
+2 SET DIR(0)="S^E:Edit and Refile Message;R:Refile Message"
+3 DO ^DIR
+4 IF $DATA(DIRUT)
QUIT 0
+5 IF $GET(Y)="E"
QUIT 0
+6 QUIT 1
+7 ;
ACCLOOK(BLRD,ACC) ;lets look up the accession number in HL(772
+1 NEW BLRDA,BLRIEN,BLRMT,BLRI,BLRM,BLRCN
+2 SET BLRMT=0
+3 SET BLRCN=0
+4 SET BLRDA=0
FOR
SET BLRDA=$ORDER(^HL(772,BLRDA))
IF 'BLRDA!($GET(BLRMT))
QUIT
Begin DoDot:1
+5 SET BLRIEN=0
FOR
SET BLRIEN=$ORDER(^HL(772,BLRDA,"IN",BLRIEN))
IF 'BLRIEN!($GET(BLRMT))
QUIT
Begin DoDot:2
+6 IF $GET(^HL(772,BLRDA,"IN",BLRIEN,0))[ACC
IF $$CHKMSG(BLRDA)
Begin DoDot:3
+7 SET BLRCN=BLRCN+1
+8 SET BLRD(BLRCN)=BLRDA
+9 ;,BLRMT=1
SET BLRD=BLRDA
SET BLRI=BLRIEN
End DoDot:3
End DoDot:2
End DoDot:1
+10 IF '$DATA(BLRD)
WRITE !,"Could not find an entry to refile"
QUIT ""
+11 NEW BLRIDA,BLRDD
+12 SET BLRIDA=0
FOR
SET BLRIDA=$ORDER(BLRD(BLRIDA))
IF 'BLRIDA
QUIT
Begin DoDot:1
+13 SET BLRDD=$GET(BLRD(BLRIDA))
+14 WRITE !!,"Entry #"_BLRIDA,!
+15 DO WRT(BLRDD)
End DoDot:1
+16 ;S BLRM=$O(^HLMA("B",BLRD,0))
+17 ;Q $G(BLRM),!
+18 QUIT $GET(BLRCN)
+19 ;
RFL(IN) ;-- ask if they want to refile
+1 ;S DIR(0)="Y",DIR("A")="Is this the entry you want to refile",DIR("B")="Y"
+2 ;D ^DIR
+3 ;Q +$G(Y)
+4 ;
+5 KILL DIR
+6 SET DIR(0)="N^1:"_IN
SET DIR("A")="Refile which entry"
+7 DO ^DIR
+8 QUIT +$GET(Y)
+9 ;
ASKA() ;-- ask the accession number
+1 KILL DIR
+2 SET DIR(0)="N"
SET DIR("A")="Which Accession/Order # Would You Like to View/Refile "
+3 DO ^DIR
+4 KILL DIR
+5 QUIT +$GET(Y)
+6 ;
CHKMSG(M) ;-- check to see if this is an ORU R01 message
+1 NEW MI
+2 SET MI=$ORDER(^HLMA("B",M,0))
+3 IF 'MI
QUIT 0
+4 IF $$GET1^DIQ(779.001,$PIECE($GET(^HLMA(MI,0)),U,14),.01)="R01"
QUIT 1
+5 QUIT 0
WRT(RD) ;-- lets call DIQ to display the entry
+1 NEW BLRI
+2 SET BLRI=0
FOR
SET BLRI=$ORDER(^HL(772,RD,"IN",BLRI))
IF 'BLRI
QUIT
Begin DoDot:1
+3 WRITE !,$GET(^HL(772,RD,"IN",BLRI,0))
End DoDot:1
+4 QUIT
+5 ;
LOOP ;-- loop the xref and call VER
+1 IF $ORDER(^BLRRLG("B",0))=""
Begin DoDot:1
+2 WRITE !,"No Files to View"
End DoDot:1
QUIT
+3 SET DIC="^INTHU("
+4 SET BLRVDA=0
FOR
SET BLRVDA=$ORDER(^BLRRLG(BLRRF,1,BLRVDA))
IF 'BLRVDA!$GET(BLRVQ)
QUIT
Begin DoDot:1
+5 IF $GET(BLRVQ)
QUIT
+6 WRITE @IOF
+7 SET (DA,BLRUIF)=$GET(^BLRRLG(BLRRF,1,BLRVDA,0))
+8 IF '$GET(^INTHU(BLRUIF,0))
Begin DoDot:2
+9 WRITE !!,"GIS HL7 Message "_BLRUIF_" has already been purged, cannot display"
End DoDot:2
QUIT
+10 DO DIQ^BLRLMR(DIC,DA)
End DoDot:1
+11 WRITE !!,"No More Messages in Batch, Exiting"
+12 HANG 2
+13 QUIT
+14 ;
SM(BLRUIF) ;-- view the message
+1 IF '$DATA(^INTHU(BLRUIF))
Begin DoDot:1
+2 WRITE !!,"GIS HL7 Message "_BLRUIF_" has already been purged, cannot display"
End DoDot:1
QUIT
+3 SET DIC="^INTHU("
+4 IF $GET(BLRVQ)
QUIT
+5 WRITE @IOF
+6 SET (DA,BLRUIF)=BLRUIF
+7 DO DIQ^BLRLMR(DIC,DA)
+8 QUIT
+9 ;
REF(UIF) ;-- mark entry as verified
+1 SET ^INLHSCH(0,$HOROLOG,UIF)=""
+2 QUIT
+3 ;cmi/flag/maw 4/8/2004 the following is not used anymore
+4 SET BLRRL=$PIECE($GET(^BLRSITE(DUZ(2),"RL")),U)
+5 IF '$GET(BLRRL)
QUIT
+6 SET BLRRLE=$PIECE($GET(^BLRRL(BLRRL,0)),U)
+7 SET BLRSCR=$ORDER(^INRHS("B","Generated: HL IHS LAB R01 "_BLRRLE_" IN-I",0))
+8 IF '$GET(BLRSCR)
QUIT
+9 SET BLRRUN="S BLRRFL=$$^IS"_$$ZERO(BLRSCR)_BLRSCR_"("_UIF_")"
+10 XECUTE BLRRUN
+11 QUIT
+12 ;
EOJ ;-- kill variables
+1 DO JOB^BLRPARAM
+2 DO EN^XBVK("BLR")
+3 QUIT
+4 ;
ZERO(SCR) ;-- find out how many zeros need to be installed
+1 IF $LENGTH(BLRSCR)=1
QUIT "0000"
+2 IF $LENGTH(BLRSCR)=2
QUIT "000"
+3 IF $LENGTH(BLRSCR)=3
QUIT "00"
+4 IF $LENGTH(BLRSCR)=4
QUIT "0"
+5 QUIT "0"
+6 ;
EDHL ;-- lets insert the accession number if not there by finding the patient and order code
+1 NEW BLRP,BLRON,BLRCDTBLRAC,BLRIN,BLRYN,BLRY,BLRM
+2 SET BLRP=$$ASKP
+3 IF '$GET(BLRP)
QUIT
+4 SET BLRON=$$ASKO
+5 IF '$GET(BLRON)
QUIT
+6 SET BLRCDT=$$ASKCDT
+7 IF '$GET(BLRCDT)
QUIT
+8 SET BLRCDT=$$FMTHL7^XLFDT(BLRCDT)
+9 IF $GET(BLRP)
IF $GET(BLRON)
IF $GET(BLRCDT)
SET BLRIN=$$MSGLOOK(.BLRD,BLRP,BLRON,BLRCDT)
+10 IF '$GET(BLRIN)
DO EOJ
QUIT
+11 ;need to change this below so BLRY is the actual message number at this point
+12 SET BLRY=$$CMSG(BLRIN)
+13 IF '$GET(BLRY)
QUIT
+14 SET BLRM=$GET(BLRD(BLRY))
+15 IF '$GET(BLRM)
QUIT
+16 DO SETOBR(BLRM)
+17 IF '$DATA(BLROBR)
QUIT
+18 DO ADDACC(.BLROBR,BLRM)
+19 DO UPACC(.BLROBR,BLRM)
+20 SET BLRYN=$$ERFL(BLRM)
+21 IF $GET(BLRYN)
Begin DoDot:1
+22 NEW BLRMA
+23 SET BLRMA=$ORDER(^HLMA("B",BLRM,0))
+24 IF 'BLRMA
QUIT
+25 DO REPROC^HLUTIL(BLRMA,"D ORU^LA7VHL")
End DoDot:1
+26 DO EOJ
+27 QUIT
+28 ;
ASKP() ;-- ask the patient chart
+1 KILL DIR
+2 SET DIR(0)="N"
SET DIR("A")="What is the patient chart number to find "
+3 DO ^DIR
+4 KILL DIR
+5 QUIT +$GET(Y)
+6 ;
ASKO() ;-- ask the order code
+1 KILL DIR
+2 SET DIR(0)="F"
SET DIR("A")="What is the order code to find "
+3 DO ^DIR
+4 KILL DIR
+5 QUIT +$GET(Y)
+6 ;
ASKCDT() ;-- ask the collection date
+1 KILL %DT
+2 SET %DT="AE"
SET %DT("A")="What is the collection date: "
+3 DO ^%DT
+4 IF Y=-1
QUIT 0
+5 QUIT +Y
+6 QUIT
+7 ;
ASKAC() ;-- ask the accession number
+1 KILL DIR
+2 SET DIR(0)="N"
SET DIR("A")="What is the accession number to insert "
+3 DO ^DIR
+4 KILL DIR
+5 QUIT +$GET(Y)
+6 ;
MSGLOOK(BLRD,PT,ON,CDT) ;lets look up the accession number in HL(772
+1 NEW BLRDA,BLRIEN,BLRMT,BLRI,BLRM,BLRCN,BLRMT
+2 SET BLRCN=0
+3 SET BLRDA=0
FOR
SET BLRDA=$ORDER(^HL(772,BLRDA))
IF 'BLRDA
QUIT
Begin DoDot:1
+4 SET BLRMT=0
+5 SET BLRIEN=0
FOR
SET BLRIEN=$ORDER(^HL(772,BLRDA,"IN",BLRIEN))
IF 'BLRIEN
QUIT
Begin DoDot:2
+6 IF $PIECE($GET(^HL(772,BLRDA,"IN",BLRIEN,0)),"|")="PID"
IF $PIECE($GET(^HL(772,BLRDA,"IN",BLRIEN,0)),"|",4)=PT
IF $$CHKMSG(BLRDA)
SET BLRMT=1
+7 IF '$GET(BLRMT)
QUIT
+8 IF $PIECE($GET(^HL(772,BLRDA,"IN",BLRIEN,0)),"|")="OBR"
IF $PIECE($PIECE($GET(^HL(772,BLRDA,"IN",BLRIEN,0)),"|",5),"^",4)=ON
IF $EXTRACT($PIECE($GET(^HL(772,BLRDA,"IN",BLRIEN,0)),"|",8),1,8)=CDT
IF $$CHKMSG(BLRDA)
SET BLRMT=2
+9 IF $GET(BLRMT)'=2
QUIT
+10 SET BLRCN=BLRCN+1
+11 SET BLRD(BLRCN)=BLRDA
+12 ;,BLRMT=1
SET BLRD=BLRDA
SET BLRI=BLRIEN
+13 KILL BLRMT
End DoDot:2
End DoDot:1
+14 IF '$DATA(BLRD)
WRITE !,"Could not find a matching entry"
QUIT ""
+15 NEW BLRIDA,BLRDD
+16 SET BLRIDA=0
FOR
SET BLRIDA=$ORDER(BLRD(BLRIDA))
IF 'BLRIDA
QUIT
Begin DoDot:1
+17 SET BLRDD=$GET(BLRD(BLRIDA))
+18 WRITE !!,"Entry #"_BLRIDA,!
+19 DO WRT(BLRDD)
End DoDot:1
+20 ;S BLRM=$O(^HLMA("B",BLRD,0))
+21 ;Q $G(BLRM),!
+22 QUIT $GET(BLRCN)
+23 ;
SETOBR(MSG) ;-- loop through the message and get the OBR and test for editing
+1 NEW MDA,CODE,DESC
+2 SET MDA=0
FOR
SET MDA=$ORDER(^HL(772,MSG,"IN",MDA))
IF 'MDA
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^HL(772,MSG,"IN",MDA,0)),"|")="OBR"
Begin DoDot:2
+4 SET CODE=$PIECE($PIECE($GET(^HL(772,MSG,"IN",MDA,0)),"|",5),"^",4)
+5 SET DESC=$PIECE($PIECE($GET(^HL(772,MSG,"IN",MDA,0)),"|",5),"^",5)
+6 SET BLROBR(MSG,MDA)=CODE_U_DESC
End DoDot:2
End DoDot:1
+7 QUIT
+8 ;
ERFL(RY) ;-- ask if they want to refile
+1 WRITE !
+2 DO WRT(RY)
+3 KILL DIR
+4 SET DIR(0)="Y"
SET DIR("A")="Ready to Refile"
+5 DO ^DIR
+6 QUIT +$GET(Y)
+7 ;
CMSG(IN) ;-- ask if they want to refile
+1 KILL DIR
+2 SET DIR(0)="N^1:"_IN
SET DIR("A")="Which message is the correct one to edit"
+3 DO ^DIR
+4 QUIT +$GET(Y)
+5 ;
ADDACC(OBR,RY) ;-- lets add the accession to the obr
+1 NEW RDA,CD,DS,SAME
+2 SET SAME=$$SAMEACC
+3 IF SAME=-1
QUIT
+4 IF SAME
Begin DoDot:1
+5 SET ACC=$$ACC("","",1)
+6 SET RDA=0
FOR
SET RDA=$ORDER(OBR(RY,RDA))
IF 'RDA
QUIT
Begin DoDot:2
+7 SET $PIECE(OBR(RY,RDA),U,3)=ACC
End DoDot:2
End DoDot:1
QUIT
+8 SET RDA=0
FOR
SET RDA=$ORDER(OBR(RY,RDA))
IF 'RDA
QUIT
Begin DoDot:1
+9 SET CD=$PIECE(OBR(RY,RDA),U)
+10 SET DS=$PIECE(OBR(RY,RDA),U,2)
+11 SET ACC=$$ACC(CD,DS,0)
+12 IF '$GET(ACC)
QUIT
+13 SET $PIECE(OBR(RY,RDA),U,3)=ACC
End DoDot:1
+14 QUIT
+15 ;
SAMEACC() ;-- same accession number for all tests
+1 KILL DIR
+2 SET DIR(0)="Y"
SET DIR("A")="Same accession number for all tests"
+3 DO ^DIR
+4 IF $DATA(DIRUT)
QUIT -1
+5 QUIT +$GET(Y)
+6 ;
ACC(C,D,T) ;-- lets get the accession number to file
+1 KILL DIR,PRM
+2 SET DIR(0)="N"
+3 SET PRM=$SELECT(T:"Accession number for all tests",1:"Accession number for test ("_C_") "_D)
+4 SET DIR("A")=PRM
+5 DO ^DIR
+6 QUIT +$GET(Y)
+7 ;
UPACC(OBR,RY) ;-- update the message with accessions
+1 NEW UDA,AC
+2 SET UDA=0
FOR
SET UDA=$ORDER(OBR(RY,UDA))
IF 'UDA
QUIT
Begin DoDot:1
+3 SET AC=$PIECE($GET(OBR(RY,UDA)),U,3)
+4 SET $PIECE(^HL(772,RY,"IN",UDA,0),"|",3)=AC
End DoDot:1
+5 QUIT
+6 ;
