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

BLRRLFX1.m

Go to the documentation of this file. 
  1. BLRRLFX1 ;IHS/CMI/THL/MAW - Refile Utility; [ 10/29/2017  7:08 AM ]
  1.  ;;5.2;IHS LABORATORY;**1041**;NOV 01, 1997;Build 23
  1.  Q
  1. EN ;EP;TO REFILE LAB MESSAGE
  1.  N QUIT,PAT,PATX,PID,MTYPE,SID,FN,FI,ACC,X,Y,Z,J,JJ,K,ONO,LOOK,ALL,DFN
  1.  N SEG,SEQ,SSN,SEX,NAM,IEN,LRDFN,LROX,LINE,LN,FN,MN,END,DOB,SEGX
  1.  S QUIT=0
  1.  W @IOF
  1.  W !?10,"Select patients and HL7 messages for ACCESSION NUMBER correction"
  1.  D MTYPE
  1.  Q:QUIT
  1.  F  D P1 Q:QUIT
  1.  Q
  1.  ;
  1. PAT ;FIND INDIVIDUAL PATIENT
  1.  S QUIT=0
  1.  F  D P1 Q:QUIT
  1.  S QUIT=0
  1.  Q
  1.  ;
  1. ALL ;FIND ALL RECENT MESSAGES WITH NO ACCESSION NUMBER
  1.  K ^TMP("BLRRLPAT"),^("BLRRLPN")
  1.  S X1=DT
  1.  S X2=-60
  1.  D C^%DTC
  1.  S END=X
  1.  I '$D(ZTQUEUED) D  Q:QUIT
  1.  .K DIR
  1.  .S DIR(0)="DO"
  1.  .S DIR("A")="Search dates since"
  1.  .D DIR
  1.  .I QUIT S QUIT=0 Q
  1.  .S END=Y
  1.  S END=(END+17000000)-1
  1.  I MTYPE=1 D AHL7
  1.  I MTYPE=2 D AINTHU
  1.  Q:$D(ZTQUEUED)
  1.  I '$D(^TMP("BLRRLPAT")) D  Q
  1.  .W !!,"No HL7 messages with missing Accession Numbers were found."
  1.  S QUIT=0
  1.  F  D LALL Q:QUIT
  1.  S QUIT=0
  1.  Q
  1.  ;
  1. P1 ;SELECT PATIENT
  1.  K ^TMP("BLRRLPAT"),^("BLRRLPN")
  1.  N ONO,PAT,SID
  1.  S (ONO,PAT,SID)=""
  1.  W @IOF
  1.  W !?10,"Select patients to search for in the '",$S(MTYPE=1:"HL(772,",1:"INTHU("),"' global"
  1.  K DIR
  1.  S DIR(0)="SO^1:Use FM patient lookup;2:Enter patient name;3:Specimen ID;4:Order No.;5:List recent messages with missing ACCESSION NUMBER"
  1.  S DIR("A")="Which user name option"
  1.  D DIR
  1.  Q:QUIT=1
  1.  S LOOK=X
  1.  I LOOK=1 D FM I 1
  1.  E  I LOOK=2 D PNAM I 1
  1.  E  I LOOK=3 D SID I 1
  1.  E  I LOOK=4 D ONO I 1
  1.  E  I LOOK=5 D ALL Q
  1.  I QUIT D  Q
  1.  .W:12[LOOK !!,"Patient name missing."
  1.  .W:LOOK=3 !!,"Specimen ID missing."
  1.  .W:LOOK=4 !!,"Order Number missing or Patient Not found for order number."
  1.  .H 2
  1.  .S QUIT=0
  1.  W !!,"We'll search for messages in"
  1.  W !!?15,"global: ",$S(MTYPE=1:"HL(772,",1:"INTHU(")
  1.  W !?10,"for patient: ",$S(PAT]"":PAT,1:"(not entered)")
  1.  W !?10,"Specimen ID: ",$S(SID]"":SID,1:"(not entered)")
  1.  W !?10,"  Order No.: ",$S(ONO]"":ONO,1:"(not entered)")
  1.  W !!?1,"that are missing the",!?5,"Accession number:"
  1.  D PAUSE
  1.  D FIND(PAT,SID,ONO)
  1.  Q:$O(^TMP("BLRRLPAT",""))=""
  1.  S:$G(PATX)]"" PAT=PATX
  1.  S:PAT="" PAT=$O(^TMP("BLRRLPAT",""))
  1.  D LIST(PAT)
  1.  K ^TMP("BLRRLPAT"),^("BLRRLPN")
  1.  Q
  1.  ;
  1. FM ;USE FM PATIENT LOOKUP
  1.  K DFN,DIC
  1.  S DIC="^DPT("
  1.  S DIC(0)="AEMQZ"
  1.  S DIC("A")="Enter PATIENT NAME or Chart Number: "
  1.  W !
  1.  D ^DIC
  1.  I Y<1 S QUIT=1 Q
  1.  S PAT=$P($P(Y,U,2),",")_U_$E($P($P(Y,U,2),",",2))
  1.  Q
  1.  ;
  1. PNAM ;ENTER PATIENT NAME DIRECTLY
  1.  K DIR
  1.  S DIR(0)="FO^1:30"
  1.  S DIR("A",1)="Enter the patient's NAME"
  1.  S DIR("A")="LASTNAME,FIRSTNAME"
  1.  D DIR
  1.  Q:QUIT
  1.  I X'?1U.U1",".U D  G PNAM
  1.  .W !!,"Enter the patient's name in the format:"
  1.  .W !!,"LASTNAME followed by a comma and the first initial or"
  1.  .W !,"any number of characters of the patient's first initial"
  1.  .H 2
  1.  S PAT=$TR(X,",","^")
  1.  Q
  1.  ;
  1. MTYPE ;IDENTIFY WHETHER THE MESSAGE IS HL(772 OR INTHU
  1.  S MTYPE=$P($G(^BLRSITE(DUZ(2),"RL")),U,22)
  1.  I MTYPE]"" D  Q
  1.  .S MTYPE=$S(MTYPE=1:1,1:2)
  1.  K DIR
  1.  S DIR(0)="SO^1:Messages in HL(772, global;2:Messages in INTHU( global"
  1.  S DIR("A")="Which global to search"
  1.  D DIR
  1.  Q:QUIT
  1.  S MTYPE=X
  1.  Q
  1.  ;
  1. ACCNUM ;ACCESSION NUMBER
  1.  K DIR,ACC
  1.  S DIR(0)="FO^10:10"
  1.  S DIR("A",1)="Enter the Missing"
  1.  S DIR("A")="Accession number"
  1.  D DIR
  1.  Q:QUIT
  1.  I X'?10N W !!,"Accession number must be 10 numeric characters." G ACCNUM
  1.  S ACC=X
  1.  Q
  1.  ;
  1. SPECID ;SPECIMEN ID
  1.  S SID=""
  1.  K DIR
  1.  S DIR(0)="FO^1:15"
  1.  S DIR("A")="Specimen ID"
  1.  D DIR
  1.  I QUIT S QUIT=0 Q
  1.  S SID=X
  1.  Q
  1.  ;
  1. FIND(PAT,SID,ONO) ;FIND MATCHING MESSAGES
  1.  I MTYPE=1 D HL7
  1.  I MTYPE=2 D INTHU
  1.  Q
  1.  ;
  1. LIST(PAT) ;LIST MESSAGES
  1.  S QUIT=0
  1.  F  D L1 Q:QUIT
  1.  S QUIT=0
  1.  Q
  1.  ;
  1. L1 ;LIST ALL MESSAGES FOR THE PATIENT
  1.  N X,Y,Z,XX
  1.  S Y=$O(^TMP("BLRRLPAT",PAT,0))
  1.  I Y,'$O(^TMP("BLRRLPAT",PAT,Y)) D IEN(PAT,Y) S QUIT=1 Q
  1.  D LHEAD(PAT)
  1.  K DIR
  1.  S DIR(0)="FO^1:15"
  1.  S DIR("A",1)="Add Accession numbers to"
  1.  S DIR("A")="OBR segments for message IEN"
  1.  D DIR
  1.  Q:QUIT
  1.  I X'?1N.N W !,"IEN must be a numeric value" G L1
  1.  I '$D(XX(X)) W !!,"IEN: ",X," not found." H 2 Q
  1.  S NAM=XX(X)
  1.  S IEN=X
  1.  D IEN(NAM,IEN)
  1.  S QUIT=0
  1.  Q
  1.  ;
  1. HL7 ;SEARCH FOR RELATED MESSAGES IN HL(772
  1.  N X,Y,Z,QUIT
  1.  S JJ=0
  1.  S QUIT=0
  1.  S X=9999999999
  1.  F  S X=$O(^HLMA(X),-1) Q:'X  S IEN=+$G(^(X,0)) I IEN,$G(^HLMA(X,"MSH",1,0))["ORU^R01",$D(^HL(772,IEN,"IN")) D
  1.  .I PAT]"",$P($G(^HL(772,IEN,"IN",1,0)),"|",6)'[PAT Q
  1.  .S PID=$P(^HL(772,IEN,"IN",1,0),"|",6)_" DOB: "_$P(^(0),"|",8)_" SEX: "_$P(^(0),"|",9)
  1.  .S J=0
  1.  .S Y=1
  1.  .F  S Y=$O(^HL(772,IEN,"IN",Y)) Q:'Y  I $G(^(Y,0))["OBR|",$P(^(0),"|",3)'?10N S XX=^(0) D
  1.  ..I SID]"",$P(XX,"|",4)'=SID Q
  1.  ..I ONO]"",$P(XX,"|",19)'=ONO Q
  1.  ..S J=J+1
  1.  ..S ^TMP("BLRRLPAT",PID,IEN,J)=Y_"***"_XX
  1.  ..I SID]"",PAT="" S PATX=PID
  1.  ..I ONO]"",PID[PAT S PATX=PID
  1.  D PN
  1.  Q
  1.  ;
  1. INTHU ;SEARCH FOR RELATED MESSAGES IN INTHU
  1.  S X=9999999999
  1.  F  S X=$O(^INTHU(X),-1) Q:'X  D:$G(^(X,3,1,0))["ORU^R01"
  1.  .I PAT]"",$P($G(^INTHU(X,3,2,0)),"|",6)'[PAT Q
  1.  .S PID=$P(^INTHU(X,3,2,0),"|",6)_" DOB: "_$P(^(0),"|",8)_" SEX: "_$P(^(0),"|",9)
  1.  .S J=0
  1.  .S Y=2
  1.  .F  S Y=$O(^INTHU(X,3,Y)) Q:'Y  I $G(^(Y,0))["OBR|",$P(^(0),"|",3)'?10N S XX=^(0) D
  1.  ..I SID]"",$P(XX,"|",4)'=SID Q
  1.  ..I ONO]"",$P(XX,"|",19)'=ONO Q
  1.  ..S J=J+1
  1.  ..S ^TMP("BLRRLPAT",PID,X,J)=Y_"***"_XX
  1.  ..I SID]"",PAT="" S PATX=PID
  1.  ..I ONO]"",PID[PAT S PATX=PID
  1.  D PN
  1.  Q
  1.  ;
  1. AHL7 ;SEARCH FOR RELATED MESSAGES IN HL(772
  1.  N X,Y,Z,QUIT
  1.  S QUIT=0
  1.  S JJ=0
  1.  S X=9999999999
  1.  F  S X=$O(^HLMA(X),-1) Q:'X!QUIT  S IEN=+$G(^(X,0)) I IEN,$G(^HLMA(X,"MSH",1,0))["ORU^R01",$E($P(^(0),"|",7),1,8)>END,$D(^HL(772,IEN,"IN")) D
  1.  .S J=0
  1.  .S Y=0
  1.  .F  S Y=$O(^HL(772,IEN,"IN",Y)) Q:'Y  I $G(^(Y,0))["PID|"!($G(^(0))["OBR|") S XX=^(0) D
  1.  ..I XX["PID|" S PID=$P(XX,"|",6)_" DOB: "_$P(XX,"|",8)_" SEX: "_$P(^(0),"|",9) Q
  1.  ..Q:$P(XX,"|",3)?10N
  1.  ..S J=J+1
  1.  ..S ^TMP("BLRRLPAT",PID,IEN,J)=Y_"***"_XX
  1.  D PN
  1.  Q
  1.  ;
  1. PN ;CREATE NUMBERED PATIENT ARRAY
  1.  S JJ=0
  1.  S X=0
  1.  F  S X=$O(^TMP("BLRRLPAT",X)) Q:X=""  S JJ=JJ+1,^TMP("BLRRLPN",JJ)=X
  1.  Q
  1.  ;
  1. AINTHU ;SEARCH FOR RELATED MESSAGES IN INTHU
  1.  S JJ=0
  1.  S X=9999999999
  1.  F  S X=$O(^INTHU(X),-1) Q:'X  I $G(^(X,3,1,0))["ORU^R01",$E($P(^(0),"|",7),1,8)>END D
  1.  .S J=0
  1.  .S Y=0
  1.  .F  S Y=$O(^INTHU(X,3,Y)) Q:'Y  I $G(^(Y,0))["PID|"!($G(^(0))["OBR|") S XX=^(0) D
  1.  ..I XX["PID|" S PID=$P(XX,"|",6)_" DOB: "_$P(XX,"|",8)_" SEX:  "_$P(^(0),"|",9) Q
  1.  ..Q:$P(XX,"|",3)?10N
  1.  ..S J=J+1
  1.  ..S ^TMP("BLRRLPAT",PID,X,J)=Y_"***"_XX
  1.  D PN
  1.  Q
  1.  ;
  1. IEN(NAM,IEN) ;SELECT SEGS TO ADD ACCESSION NUMBER TO
  1.  S X=$O(^TMP("BLRRLPAT",NAM,IEN,0))
  1.  I '$O(^TMP("BLRRLPAT",NAM,IEN,X)) D  Q
  1.  .D CHANGE(NAM,IEN,X)
  1.  .Q:QUIT
  1.  .I 'QUIT D REFILE(NAM,IEN)
  1.  .S QUIT=0
  1.  D IENHEAD(NAM,IEN)
  1.  K DIR
  1.  S DIR(0)="LO^1:"_J
  1.  S DIR("A")="Select sequence number(s) for segments to change"
  1.  D DIR
  1.  I QUIT S QUIT=0 Q
  1.  S ALL=Y
  1.  S K=0
  1.  F J=1:1:($L(ALL,",")-1) S SEQ=$P(ALL,",",J) D CHANGE(NAM,IEN,SEQ)
  1.  I QUIT S QUIT=0 Q
  1.  D REFILE(NAM,IEN)
  1.  Q
  1.  ;
  1. CHANGE(NAM,IEN,SEQ) ;ENTER AN AND CHANGE SEGMENT
  1. CH1 W @IOF
  1.  S QUIT=0
  1.  S X=$G(^TMP("BLRRLPAT",NAM,IEN,SEQ))
  1.  Q:X=""
  1.  S SEG=+X
  1.  S SEGX=$P(X,"***",2)
  1.  W !!,"    Patient: ",NAM
  1.  W !,"Message IEN: ",IEN
  1.  W !,"Sequence No: ",SEQ
  1.  W !," Segment No: ",SEG
  1.  W !!?5,SEGX
  1.  S DFN=$$DFN(NAM)
  1.  D:DFN ACC(DFN,IEN,SEG,SEGX)
  1.  D:$D(ACC(1))
  1.  .W !!?5,"No.",?10,"Accession Number"
  1.  .W !?5,"---",?10,"----------------"
  1.  .S J=0
  1.  .F  S J=$O(ACC(J)) Q:'J  W !?5,J,?10,ACC(J)
  1.  S ACC=""
  1.  D ACCS
  1.  I QUIT D  Q
  1.  .W !!,"Accession number not specified."
  1.  .H 2
  1.  I ACC="" G CH1
  1.  K DIR
  1.  S DIR(0)="YO"
  1.  S DIR("A",1)="Is "_ACC_" the correct"
  1.  S DIR("A")="Accession Number for segment "_SEG_" "
  1.  S DIR("B")="YES"
  1.  D DIR
  1.  I Y'=1 S K=K+1 Q  S:K=($L(ALL,",")-1) QUIT=1 Q
  1. C1 I MTYPE=1 S $P(^TMP("BLRRLPAT",NAM,IEN,SEQ),"|",3)=ACC
  1.  I MTYPE=2 S $P(^TMP("BLRRLPAT",NAM,IEN,SEQ),"|",3)=ACC
  1. C2 I MTYPE=1 S $P(^HL(772,IEN,"IN",SEG,0),"|",3)=ACC
  1.  I MTYPE=2 S $P(^INTHU(IEN,3,SEG,0),"|",3)=ACC
  1.  Q
  1.  ;
  1. REFILE(NAM,IEN) ;REFILE THE MESSAGE
  1.  I $G(MTYPE)=1 D  Q:'BLRRLMA
  1.  .S BLRRLMA=$O(^HLMA("B",IEN,0))
  1.  I MTYPE=1 D EN^XBNEW("CALLHL^BLRRLFX1","BLRRLMA")
  1.  I MTYPE=2 S ^INLHSCH(0,$H,IEN)=""
  1.  Q:$D(ZTQUEUED)
  1.  W !!," HL7 Message IEN: ",IEN," has been refiled with"
  1.  W !,"Accession Number: ",ACC
  1.  D PAUSE
  1.  Q
  1.  ;
  1. LALL ;LIST ALL MESSAGES WITHOUT ACCESSION NUMBER
  1.  S QUIT=0
  1.  D AHEAD
  1.  S JJ=0
  1.  F  S JJ=$O(^TMP("BLRRLPN",JJ)) Q:JJ=""!QUIT  S XX=^(JJ) D
  1.  .W !,JJ,?10,$P(XX,"DOB:")
  1.  .W ?40,"DOB: ",$P($P(XX,"SEX:"),"DOB:",2)
  1.  .W ?56,"SEX: ",$P(XX,"SEX:",2)
  1.  .I JJ>1,JJ#20=0 D  Q:QUIT
  1.  ..W !,"---------------------------"
  1.  ..D LINE
  1.  ..Q:QUIT
  1.  ..D AHEAD
  1.  S QUIT=0
  1.  S JJ=$O(^TMP("BLRRLPN",9999999999),-1)
  1.  S NAM=$$ASEL(JJ)
  1.  Q:QUIT
  1.  D LIST(NAM)
  1.  Q
  1.  ;
  1. ASEL(NUM) ;SELECT PATIENT TO EDIT
  1.  S NAM=""
  1.  K DIR
  1.  S DIR(0)="NO^1:"_NUM
  1.  S DIR("A")="Which Patient"
  1.  D DIR
  1.  Q:QUIT ""
  1.  I 'X!'$D(^TMP("BLRRLPN",+X)) W !,"Enter a number from 1 to ",JJ Q ""
  1.  S NAM=$G(^TMP("BLRRLPN",X))
  1.  Q NAM
  1.  ;
  1. LINE ;
  1.  Q:$D(ZTQUEUED)
  1.  W !!,"Press <ENTER> to continue,"
  1.  R !,"Enter '^' followed by <ENTER> to exit...",XXX:DTIME
  1.  S:XXX[U QUIT=1
  1.  Q
  1.  ;
  1.  W @IOF
  1.  W !?10,"HL7 Messages for ",PAT
  1.  W !?10,"with missing ACCESSION NUMBER"
  1.  W !!,"Message",?10,"Sequence",?20,"Segment"
  1.  W !,"IEN",?10,"NO.",?20,"NO."
  1.  W !,"--------",?10,"--------",?20,"-------"
  1.  S LINE=0
  1.  S JJ=0
  1.  S X=$E(NAM,1,$L(NAM)-1)
  1.  F  S X=$O(^TMP("BLRRLPAT",X)) Q:X'[NAM  D
  1.  .W !?10,X
  1.  .S Y=0
  1.  .F  S Y=$O(^TMP("BLRRLPAT",X,Y)) Q:'Y  D
  1.  ..S XX(Y)=X
  1.  ..S LINE=LINE+1
  1.  ..D LINE:(LINE#20=0)
  1.  ..W !,Y
  1.  ..Q:QUIT
  1.  ..S K=0
  1.  ..S Z=0
  1.  ..F  S Z=$O(^TMP("BLRRLPAT",X,Y,Z)) Q:'Z  S XX=^(Z) D
  1.  ...S K=K+1
  1.  ...S LINE=LINE+1 D LINE:(LINE#20=0) Q:QUIT
  1.  ...W:K>1 !
  1.  ...W ?10,Z,?20,+XX,?27,$E($P(XX,"***",2),1,48),"..."
  1.  Q
  1.  ;
  1. IENHEAD(NAM,IEN) ;LIST IEN SEGMENTS
  1.  W @IOF
  1.  W !?10,"OBR segments with missing Accession"
  1.  W !?10,"Number for message: ",IEN
  1.  W !!,"Message",?10,"Sequence",?20,"Segment"
  1.  W !,"IEN",?10,"NO.",?20,"NO."
  1.  W !,"--------",?10,"--------",?20,"-------"
  1.  W !,IEN
  1.  S J=0
  1.  S X=0
  1.  F  S X=$O(^TMP("BLRRLPAT",NAM,IEN,X)) Q:'X  S XX=^(X) D
  1.  .S J=X
  1.  .W:J>1 !
  1.  .W ?10,X,?20,+XX,?27,$E($P(XX,"***",2),1,48),"..."
  1.  Q
  1.  ;
  1. AHEAD ;HEADER
  1.  W @IOF
  1.  W !,"No.",?10,"Patient"
  1.  W !,"-----",?10,"----------------------------------------"
  1.  Q
  1.  ;
  1. PAUSE ;
  1.  Q:$D(ZTQUEUED)
  1.  R !!,"Press <ENTER> to continue...",XXX:DTIME
  1.  Q
  1.  ;
  1. DFN(NAM) ;FIND PATIENT DFN
  1.  S X=$P(NAM," DOB: ")
  1.  S DOB=$P($P(NAM,"SEX: "),"DOB: ",2)-17000000
  1.  S SEX=$P(NAM,"SEX: ",2)
  1.  S LN=$P(X,U)
  1.  S FN=$P(X,U,2)
  1.  S MN=$P(X,U,3)
  1.  S X=LN_","_FN_$S(MN]"":" "_MN,1:"")
  1.  S DIC="^DPT("
  1.  S DIC(0)="M"
  1.  S DIC("S")="I $P(^(0),U,3)=DOB,$P(^(0),U,2)=SEX"
  1.  D ^DIC
  1.  I Y<1 Q ""
  1.  Q +Y
  1.  ;
  1. ACC(DFN,IEN,SEG,SEGX) ;FIND RECENT ACCESSION NUMBERS
  1.  N X,Y,Z,PAT,DAT,LRO,DATX
  1.  K ACC
  1.  S DAT=$E($P(SEGX,"|",9),1,8)-17000000
  1.  S DATX=DAT_"."_$E($P(SEGX,"|",8),9,12)
  1.  Q:'DAT
  1.  ;F LROX="SENDOUT","REFERENCE" S LRO=$O(^LRO(68,"B",LROX,0)) D:LRO A1
  1.  S LRO=0
  1.  F  S LRO=$O(^LRO(68,LRO)) Q:'LRO  S LROX=$P(^(LRO,0),U) D A1
  1.  Q
  1.  ;
  1. A1 ;
  1.  S DX=DAT-1
  1.  F  S DX=$O(^LRO(68,LRO,1,DX)) Q:'DX!(DX'[DAT)  D
  1.  .S J=0
  1.  .S X=0
  1.  .F  S X=$O(^LRO(68,LRO,1,DX,1,X)) Q:'X  I +$G(^(X,0))=DFN S Y=$P($G(^(3)),U),ACC=$P($G(^(.3)),U) D:ACC
  1.  ..S J=J+1
  1.  ..S ACC(J)=ACC_U_LROX
  1.  ..S PAT=$P($G(^DPT(DFN,0)),U)
  1.  ..Q:PAT=""
  1.  ..S $P(SEGX,"|",3)=ACC
  1.  ..S ^TMP("BLRR MATCH",PAT,IEN,SEG)=ACC_U_SEGX
  1.  Q
  1.  ;
  1. MATCH ;PROCESS MESSAGES AND MATCH WITH FILE 68
  1.  N X,Y,Z
  1.  S X=""
  1.  F  S X=$O(^TMP("BLRRLPAT",X)) Q:X=""  D
  1.  .S Y=0
  1.  .F  S Y=$O(^TMP("BLRRLPAT",X,Y)) Q:'Y  D
  1.  ..S Z=0
  1.  ..F  S Z=$O(^TMP("BLRRLPAT",X,Y,Z)) Q:'Z  S XX=$G(^(Z)) D:XX M1(X,Y,Z,XX)
  1.  Q
  1.  ;
  1. M1(PAT,IEN,SEQ,XX) ;PROCESS EACH SEGMENT
  1.  S SEG=+XX
  1.  S SEGX=$P(XX,"***",2)
  1.  S DFN=$$DFN(PAT)
  1.  Q:'DFN
  1.  D ACC(DFN,IEN,SEG,SEGX)
  1.  Q:'$O(ACC(0))
  1.  Q
  1.  ;
  1. MON ;MONITOR AUTO ACC MATCHES
  1.  Q:$O(^TMP("BLRR MATCH",""))=""
  1.  D MDISP
  1.  S QUIT=0
  1.  F  D MSEL Q:QUIT
  1.  S QUIT=0
  1.  Q
  1.  ;
  1. MSEL ;SELECT MATCHES TO PROCESS
  1.  K DIR
  1.  S DIR(0)="LO^1:"_JJ
  1.  S DIR("A")="Select all for which the Accession Number is correct"
  1.  D DIR
  1.  Q:QUIT=1
  1.  I 'X W !,"Enter a number or list of number from 1 to ",JJ G MSEL
  1.  S ALL=Y
  1.  S K=0
  1.  F J=1:1:($L(ALL,",")-1) S SEQ=$P(ALL,",",J),X=^TMP("BLRR PROC",SEQ) D P1S(X)
  1.  Q
  1.  ;
  1. P1S(X) ;
  1.  S IEN=$P(X,U)
  1.  S SEG=$P(X,U,2)
  1.  S ACC=$P(X,U,3)
  1.  D C2
  1.  D REFILE(NAM,IEN)
  1.  Q
  1.  ;
  1. MDISP ;DISPLAY MATCH LOG
  1.  D MHEAD
  1.  N X,Y,Z
  1.  S J=0
  1.  S X=0
  1.  F  S X=$O(^TMP("BLRR MATCH",X)) Q:X=""  D
  1.  .S Y=0
  1.  .F  S Y=$O(^TMP("BLRR MATCH",X,Y)) Q:'Y  D
  1.  ..S Z=0
  1.  ..F  S X=$O(^TMP("BLRR MATCH",X,Y,Z)) Q:'Z  S XX=^(Z) D
  1.  ...S J=J+1
  1.  ...W !,J,?5,X,?35,Y,?45,Z
  1.  ...W !?5,$P(XX,U,2)
  1.  ...S ^TMP("BLRR PROC",JJ)=Y_U_Z_U_$P(XX,U,1,99)
  1.  S JJ=J
  1.  Q
  1.  ;
  1. MHEAD ;HEADER TO DISPLAY MATCH LOG
  1.  Q:$D(ZTQUEUED)
  1.  W @IOF
  1.  W !?5,"Accession Number Matches for HL7 Messages"
  1.  W !!,"Seq",?35,"Message"
  1.  W !,"No.",?5,"Patient",?35,"IEN",?45,"Seg"
  1.  W !,"----",?5,"-----------------------------",?35,"---------",?45,"---"
  1.  Q
  1.  ;
  1. CALLHL ;CALL HL REFILER
  1.  N ORIGDUZ
  1.  S ORIGDUZ=DUZ
  1.  D REPROC^HLUTIL(BLRRLMA,"D ORU^LA7VHL")
  1.  D DUZ^XUP(ORIGDUZ)
  1.  K BLRRLMA
  1.  Q
  1.  ;
  1. SID ;ENTER SPECIMEN ID TO SEARCH FOR     
  1.  K DIR
  1.  S DIR(0)="FO^1:30^I X'?1U.UN"
  1.  S DIR("A")="Enter the Specimen ID"
  1.  D DIR
  1.  Q:QUIT
  1.  I X'?1U.UN D  G SID
  1.  .W !!,"Response must be 1 or 2 uppercase letters"
  1.  .W !,"followed by numbers, e.g. WX12345"
  1.  .H 2
  1.  S SID=X
  1.  Q
  1.  ;
  1. ONO ;ENTER ORDER NUMBER TO SEARCH FOR
  1.  K DIR
  1.  S DIR(0)="FO^1:30"
  1.  S DIR("A")="Enter the Order Number"
  1.  D DIR
  1.  Q:QUIT
  1.  I X'?1N.N D  G ONO
  1.  .W !!,"Response must be numeric"
  1.  .H 2
  1.  S ONO=X
  1.  S DA(1)=+$O(^LRO(69,"C",X,0))
  1.  S DA=+$O(^LRO(69,"C",X,DA(1),0))
  1.  S LRDFN=+$G(^LRO(69,DA(1),1,DA,0))
  1.  D PATN(LRDFN)
  1.  I PAT="" S QUIT=1 Q
  1.  Q
  1.  ;
  1. DIR ;READER
  1.  W !!
  1.  D ^DIR
  1.  K DIR
  1.  I X[U!(X="") S QUIT=1
  1.  Q
  1.  ;
  1. PATN(X) ;PATIENT NAME
  1.  S Y=$P($G(^DPT(X,0)),U)
  1.  S PAT=$P(Y,",")_U_$P($P(Y,",",2)," ")
  1.  Q
  1.  ;
  1. DMESS(IEN) ;DISPLAY HL7 MESSAGE
  1.  W @IOF
  1.  W !?10,"HL7 Message Text"
  1.  w !?10,"---------------------------------"
  1.  I MTYPE=1 D DM1
  1.  I MTYPE=2 D DM2
  1.  D PAUSE
  1.  Q
  1.  ;
  1. DM1 ;HL(772
  1.  N X,Y,Z
  1.  S LINE=2
  1.  S X=$O(^HLMA("B",IEN,0))
  1.  W !,$E($G(^HLMA(X,"MSH",1,0)),1,80)
  1.  S X=0
  1.  F  S X=$O(^HL(772,IEN,"IN",X)) Q:'X  S Y=^(X,0) D
  1.  .S LINE=LINE+1
  1.  .D LINE:(LINE#20=0)
  1.  .W !,$E(Y,1,80)
  1.  Q
  1.  ;
  1. DM2 ;INTHU
  1.  N X,Y,Z
  1.  S LINE=0
  1.  S X=0
  1.  F  S X=$O(^INTHU(IEN,3,X)) Q:'X  S Y=^(X,0) D
  1.  .S LINE=LINE+1
  1.  .D LINE:(LINE#20=0)
  1.  .W !,$E(Y,1,80)
  1.  Q
  1.  ;
  1. ACCS ;DISPLAY MESSAGE OR ENTER AN
  1.  K DIR
  1.  S DIR(0)="SO^E:Enter Missing Accession Number;D:Display HL7 Message"
  1.  S DIR("A")="Which option"
  1.  D DIR
  1.  Q:QUIT
  1.  I "ED"'[X W !!,"Select either 'E' to Enter missing Accession Number or 'D' to Display the HL7 message."  G ACCS
  1.  I X="E" D ACCNUM Q
  1.  I X="D" D DMESS(IEN) Q
  1.  Q
  1.  ;