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