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

BLRRLMV.m

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