LA7HDR1 ;DALOI/JMC - LAB HDR ORU (Observation Result) message builder (cont'd) ;July 28, 2008
;;5.2;AUTOMATED LAB INSTRUMENTS;**68**;Sep 27, 1994;Build 56
;
; Reference to variable DIQUIET supported by DBIA #2098
;
Q
;
;
HDRLOAD ; Load patient's historical lab results to HDR (Health Data Repository).
; Called from tasked option LA7TASK HDR LOAD
N DIQUIET,GBL
N LA7101,LA761,LA76248,LA76249,LA76249P
N LA7CODE,LA7CNT,LA7DT,LA7ECH,LA7ERR,LA7FS,LA7ID,LA7INTYP,LA7MID,LA7MTYP,LA7NOMSG,LA7NTESN,LA7NVAF,LA7OBRSN,LA7OBXSN,LA7PIDSN,LA7RSITE,LA7QUIT,LA7SC,LA7SPEC
N LRDFN,LRIDT,LRSS,LRSSLST,LRUID,SITE
;
; Prevent FileMan from issuing any unwanted WRITE(s).
S DIQUIET=1,DT=$$DT^XLFDT
;
; Find entry in #62.48 and check if it's active.
S (LA7RSITE,SITE)="LA7HDR",LA76248=$O(^LAHM(62.48,"B",LA7RSITE,0))
; No entry in 62.48 - *** Need to add error logging ****
I 'LA76248 Q
I '$P(^LAHM(62.48,LA76248,0),"^",3) Q ; not active
S LA7INTYP=+$P(^LAHM(62.48,LA76248,0),"^",9)
;
S (LA7CNT,LA7CNT(1),LA7ERR,LA7NVAF,LA7QUIT)=0,LA7MTYP="ORU",LA7NOMSG=2
I LA7EVENT="" S LA7EVNT="LA7 LAB RESULTS AVAILABLE (EVN)"
; Setup search and subscript list
S (LA7SC,LA7SPEC)="*"
D SCLIST^LA7QRY2(LA7SC,.LRSSLST)
; Check start/end dates
I '$G(LA7SDT) S LA7SDT=$$FMADD^XLFDT(DT,-730,0,0,0)
I '$G(LA7EDT) S LA7EDT=DT
I LA7SDT>LA7EDT S X=LA7SDT,LA7SDT=LA7EDT,LA7EDT=X
;
S GBL="^TMP(""HLS"","_$J_")"
; Limit number of messages built this session.
S LA7LIMIT=$G(LA7LIMIT,1000)
;
I $D(^XTMP("LA7HDR","LRDFN")) S LRDFN=$P(^XTMP("LA7HDR","LRDFN"),"^")
E S LRDFN=0
I LRDFN'=+LRDFN Q
F S LRDFN=$O(^LR(LRDFN)) Q:'LRDFN D Q:LA7QUIT
. I $$S^%ZTLOAD("Processing LRDFN "_LRDFN_" for HDR Historical") S (LA7QUIT,ZTSTOP)=1,LRDFN=LRDFN-1 Q
. S LA7CNT(1)=LA7CNT(1)+1
. I '(LA7CNT(1)#100) H 1 ; take a "rest" - allow OS to swap out process
. S X=^LR(LRDFN,0) Q:$P(X,"^",2)'=2
. S DFN=$P(X,"^",3),LA7ID=SITE_"-O-"_$$GET1^DIQ(2,DFN_",",.01)
. K ^TMP("LA7-QRY",$J),^TMP("LA7VS",$J)
. D BCD^LA7QRY2 S LA7QUIT=0 Q:'$D(^TMP("LA7-QRY",$J))
. S LA76249=$$INIT6249^LA7VHLU,^TMP("LA7VS",$J,LA76249)=LA76249
. D INITHL^LA7VHLU(LA7EVNT)
. I $G(HL) S LA7QUIT=1,LRDFN=LRDFN-1 Q
. D BUILDMSG^LA7QRY1,GEN^LA7VHLU,UPDT6249^LA7VORM1
. S LA7CNT=LA7CNT+1,LA7QUIT=$S(LA7CNT<LA7LIMIT:0,1:1)
;
; Update XTMP entry, save last LRDFN processed for next session.
S ^XTMP("LA7HDR",0)=$$FMADD^XLFDT(DT,90,0,0,0)_"^"_DT_"^Lab historical results feed to HDR"
S ^XTMP("LA7HDR","LRDFN")=LRDFN
;
D EXIT
Q
;
;
RECOVER ; Recover failed transmissions or message building
;
N DIR,DIRUT,DTOUT,DUOUT,FIRST,LA76248,LA7CNT,LA7PROD,LA7QUIT,LA7TYPE,LA7UID,LA7X,LA7Y,LAST,LRAA,LRACC,LRAD,LRAN,LRDFN,LREXMPT,LRIDT,LRSPEC,LRSS,X,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
S (LA7CNT,LA7QUIT)=0
;
S LA76248=$O(^LAHM(62.48,"B","LA7HDR",0))
I 'LA76248 W !,"No entry LA7HDR in file #62.48" Q
I '$P(^LAHM(62.48,LA76248,0),"^",3) D Q
. S DIR(0)="EA"
. S DIR("A")="Enter RETURN to continue:"
. S DIR("A",1)="Entry LA7HDR is not active in file #62.48"
. D ^DIR
;
S LA7PROD=$$PROD^XUPROD(0)
;
S DIR(0)="SO^1:Range of Accessions;2:Selected Accessions"
S DIR("A")="Selection Method",DIR("B")=1
D ^DIR
I $D(DIRUT) Q
S LA7TYPE=+Y
;
; Get list of accession numbers, set flags used by LRWU4.
S LRACC=1,LREXMPT=1
I LA7TYPE=1 D
. D ^LRWU4
. I LRAN<1 S LA7QUIT=1 Q
. S FIRST=LRAN,X=$O(^LRO(68,LRAA,1,LRAD,1,":"),-1)
. S DIR(0)="NO^"_LRAN_":"_X_":0",DIR("B")=LRAN
. S DIR("A",1)="",DIR("A")="Recover accessions from "_LRAN_" to"
. D ^DIR K DIR
. I $D(DIRUT) S LA7QUIT=1 Q
. S LRAN=FIRST-1,LAST=Y
. F S LRAN=$O(^LRO(68,LRAA,1,LRAD,1,LRAN)) Q:'LRAN!(LRAN>LAST) D SETTMP
I LA7TYPE=2 F D Q:LA7QUIT!(LRAN<1)
. D ^LRWU4
. I $D(DTOUT)!($D(DUOUT)) S LA7QUIT=1 Q
. I LRAN<1 S:'$D(^TMP("LA7S-RTM",$J)) LA7QUIT=1 Q
. D SETTMP
I LA7QUIT Q
;
I '$D(^TMP("LA7S-RTM",$J)) D Q
. S DIR("A",1)="No accessions found to retransmit."
. S DIR("A")="Enter RETURN to continue or '^' to exit"
. S DIR(0)="E"
. D ^DIR
;
S DIR("A")="Ready to retransmit"
S DIR("A",1)="Found "_LA7CNT_" accessions that can be retransmitted."
S DIR(0)="YO",DIR("B")="NO"
D ^DIR K DIR
I Y'=1 K ^TMP("LA7S-RTM",$J) Q
D EN^DDIOL("Working","","!")
;
K LA7Y
S LA7CNT=0,LA7UID=""
F S LA7UID=$O(^TMP("LA7S-RTM",$J,LA7UID)) Q:LA7UID="" D
. K LA7X,ZTSAVE
. S LA7X=^TMP("LA7S-RTM",$J,LA7UID),LA7CNT=LA7CNT+1
. S ZTRTN="BUILD^LA7HDR",ZTDTH=$H,ZTIO="",ZTDESC="Tasked Lab HL7 HDR ORU Build"
. S ZTSAVE("LRAA")=$P(LA7X,"^"),ZTSAVE("LRAD")=$P(LA7X,"^",2),ZTSAVE("LRAN")=$P(LA7X,"^",3)
. S ZTSAVE("LRDFN")=$P(LA7X,"^",4),ZTSAVE("LRSS")=$P(LA7X,"^",5),ZTSAVE("LRIDT")=$P(LA7X,"^",6),ZTSAVE("LA7MTYP")="ORU"
. I $P(LA7X,"^",5)="CH" S ZTSAVE("LRSPEC")=$P(LA7X,"^",7)
. D ^%ZTLOAD
. I $G(ZTSK) D
. . I LA7CNT>101 Q
. . I LA7CNT=101 S LA7Y(101)="*** Too many accessions to list (>100), list truncated... ***" Q
. . S LA7Y(LA7CNT)="Task# "_ZTSK_" queued for processing accession "_LA7UID
. E S LA7Y(LA7CNT)="*** Tasking of retransmission failed for accession "_LA7UID_" ***"
S LA7Y(.1)="...Done",LA7X(1,"F")=""
S LA7Y(.2)=LA7CNT_" accession"_$S(LA7CNT>1:"s",1:"")_" scheduled for retransmitting of results!"
D EN^DDIOL(.LA7Y)
K ^TMP("LA7S-RTM",$J)
;
Q
;
;
SETTMP ;
;
S LA7UID=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^")
I LA7UID="" Q
S LRDFN=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^")
; Quit if not a file #2 patient.
I $P($G(^LR(LRDFN,0)),"^",2)'=2 Q
; Quit if test patient on a production account.
I $$TESTPAT^VADPT($P($G(^LR(LRDFN,0)),"^",3)),LA7PROD Q
S LRSS=$P($G(^LRO(68,LRAA,0)),"^",2),LRIDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5)
I LRSS?1(1"CH",1"MI") S LRSPEC=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1)),"^")
E S LRSPEC=""
S LA7CNT=LA7CNT+1,^TMP("LA7S-RTM",$J,LA7UID)=LRAA_"^"_LRAD_"^"_LRAN_"^"_LRDFN_"^"_LRSS_"^"_LRIDT_"^"_LRSPEC
Q
;
;
EXIT ;
K LA7LIMIT
D CLEANUP^LA7QRY,EXIT^LA7VORM1
K @GBL,^TMP("LA7VS",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7HDR1 6059 printed Sep 23, 2025@19:15:07 Page 2
LA7HDR1 ;DALOI/JMC - LAB HDR ORU (Observation Result) message builder (cont'd) ;July 28, 2008
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**68**;Sep 27, 1994;Build 56
+2 ;
+3 ; Reference to variable DIQUIET supported by DBIA #2098
+4 ;
+5 QUIT
+6 ;
+7 ;
HDRLOAD ; Load patient's historical lab results to HDR (Health Data Repository).
+1 ; Called from tasked option LA7TASK HDR LOAD
+2 NEW DIQUIET,GBL
+3 NEW LA7101,LA761,LA76248,LA76249,LA76249P
+4 NEW LA7CODE,LA7CNT,LA7DT,LA7ECH,LA7ERR,LA7FS,LA7ID,LA7INTYP,LA7MID,LA7MTYP,LA7NOMSG,LA7NTESN,LA7NVAF,LA7OBRSN,LA7OBXSN,LA7PIDSN,LA7RSITE,LA7QUIT,LA7SC,LA7SPEC
+5 NEW LRDFN,LRIDT,LRSS,LRSSLST,LRUID,SITE
+6 ;
+7 ; Prevent FileMan from issuing any unwanted WRITE(s).
+8 SET DIQUIET=1
SET DT=$$DT^XLFDT
+9 ;
+10 ; Find entry in #62.48 and check if it's active.
+11 SET (LA7RSITE,SITE)="LA7HDR"
SET LA76248=$ORDER(^LAHM(62.48,"B",LA7RSITE,0))
+12 ; No entry in 62.48 - *** Need to add error logging ****
+13 IF 'LA76248
QUIT
+14 ; not active
IF '$PIECE(^LAHM(62.48,LA76248,0),"^",3)
QUIT
+15 SET LA7INTYP=+$PIECE(^LAHM(62.48,LA76248,0),"^",9)
+16 ;
+17 SET (LA7CNT,LA7CNT(1),LA7ERR,LA7NVAF,LA7QUIT)=0
SET LA7MTYP="ORU"
SET LA7NOMSG=2
+18 IF LA7EVENT=""
SET LA7EVNT="LA7 LAB RESULTS AVAILABLE (EVN)"
+19 ; Setup search and subscript list
+20 SET (LA7SC,LA7SPEC)="*"
+21 DO SCLIST^LA7QRY2(LA7SC,.LRSSLST)
+22 ; Check start/end dates
+23 IF '$GET(LA7SDT)
SET LA7SDT=$$FMADD^XLFDT(DT,-730,0,0,0)
+24 IF '$GET(LA7EDT)
SET LA7EDT=DT
+25 IF LA7SDT>LA7EDT
SET X=LA7SDT
SET LA7SDT=LA7EDT
SET LA7EDT=X
+26 ;
+27 SET GBL="^TMP(""HLS"","_$JOB_")"
+28 ; Limit number of messages built this session.
+29 SET LA7LIMIT=$GET(LA7LIMIT,1000)
+30 ;
+31 IF $DATA(^XTMP("LA7HDR","LRDFN"))
SET LRDFN=$PIECE(^XTMP("LA7HDR","LRDFN"),"^")
+32 IF '$TEST
SET LRDFN=0
+33 IF LRDFN'=+LRDFN
QUIT
+34 FOR
SET LRDFN=$ORDER(^LR(LRDFN))
if 'LRDFN
QUIT
Begin DoDot:1
+35 IF $$S^%ZTLOAD("Processing LRDFN "_LRDFN_" for HDR Historical")
SET (LA7QUIT,ZTSTOP)=1
SET LRDFN=LRDFN-1
QUIT
+36 SET LA7CNT(1)=LA7CNT(1)+1
+37 ; take a "rest" - allow OS to swap out process
IF '(LA7CNT(1)#100)
HANG 1
+38 SET X=^LR(LRDFN,0)
if $PIECE(X,"^",2)'=2
QUIT
+39 SET DFN=$PIECE(X,"^",3)
SET LA7ID=SITE_"-O-"_$$GET1^DIQ(2,DFN_",",.01)
+40 KILL ^TMP("LA7-QRY",$JOB),^TMP("LA7VS",$JOB)
+41 DO BCD^LA7QRY2
SET LA7QUIT=0
if '$DATA(^TMP("LA7-QRY",$JOB))
QUIT
+42 SET LA76249=$$INIT6249^LA7VHLU
SET ^TMP("LA7VS",$JOB,LA76249)=LA76249
+43 DO INITHL^LA7VHLU(LA7EVNT)
+44 IF $GET(HL)
SET LA7QUIT=1
SET LRDFN=LRDFN-1
QUIT
+45 DO BUILDMSG^LA7QRY1
DO GEN^LA7VHLU
DO UPDT6249^LA7VORM1
+46 SET LA7CNT=LA7CNT+1
SET LA7QUIT=$SELECT(LA7CNT<LA7LIMIT:0,1:1)
End DoDot:1
if LA7QUIT
QUIT
+47 ;
+48 ; Update XTMP entry, save last LRDFN processed for next session.
+49 SET ^XTMP("LA7HDR",0)=$$FMADD^XLFDT(DT,90,0,0,0)_"^"_DT_"^Lab historical results feed to HDR"
+50 SET ^XTMP("LA7HDR","LRDFN")=LRDFN
+51 ;
+52 DO EXIT
+53 QUIT
+54 ;
+55 ;
RECOVER ; Recover failed transmissions or message building
+1 ;
+2 NEW DIR,DIRUT,DTOUT,DUOUT,FIRST,LA76248,LA7CNT,LA7PROD,LA7QUIT,LA7TYPE,LA7UID,LA7X,LA7Y,LAST,LRAA,LRACC,LRAD,LRAN,LRDFN,LREXMPT,LRIDT,LRSPEC,LRSS,X,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
+3 SET (LA7CNT,LA7QUIT)=0
+4 ;
+5 SET LA76248=$ORDER(^LAHM(62.48,"B","LA7HDR",0))
+6 IF 'LA76248
WRITE !,"No entry LA7HDR in file #62.48"
QUIT
+7 IF '$PIECE(^LAHM(62.48,LA76248,0),"^",3)
Begin DoDot:1
+8 SET DIR(0)="EA"
+9 SET DIR("A")="Enter RETURN to continue:"
+10 SET DIR("A",1)="Entry LA7HDR is not active in file #62.48"
+11 DO ^DIR
End DoDot:1
QUIT
+12 ;
+13 SET LA7PROD=$$PROD^XUPROD(0)
+14 ;
+15 SET DIR(0)="SO^1:Range of Accessions;2:Selected Accessions"
+16 SET DIR("A")="Selection Method"
SET DIR("B")=1
+17 DO ^DIR
+18 IF $DATA(DIRUT)
QUIT
+19 SET LA7TYPE=+Y
+20 ;
+21 ; Get list of accession numbers, set flags used by LRWU4.
+22 SET LRACC=1
SET LREXMPT=1
+23 IF LA7TYPE=1
Begin DoDot:1
+24 DO ^LRWU4
+25 IF LRAN<1
SET LA7QUIT=1
QUIT
+26 SET FIRST=LRAN
SET X=$ORDER(^LRO(68,LRAA,1,LRAD,1,":"),-1)
+27 SET DIR(0)="NO^"_LRAN_":"_X_":0"
SET DIR("B")=LRAN
+28 SET DIR("A",1)=""
SET DIR("A")="Recover accessions from "_LRAN_" to"
+29 DO ^DIR
KILL DIR
+30 IF $DATA(DIRUT)
SET LA7QUIT=1
QUIT
+31 SET LRAN=FIRST-1
SET LAST=Y
+32 FOR
SET LRAN=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN))
if 'LRAN!(LRAN>LAST)
QUIT
DO SETTMP
End DoDot:1
+33 IF LA7TYPE=2
FOR
Begin DoDot:1
+34 DO ^LRWU4
+35 IF $DATA(DTOUT)!($DATA(DUOUT))
SET LA7QUIT=1
QUIT
+36 IF LRAN<1
if '$DATA(^TMP("LA7S-RTM",$JOB))
SET LA7QUIT=1
QUIT
+37 DO SETTMP
End DoDot:1
if LA7QUIT!(LRAN<1)
QUIT
+38 IF LA7QUIT
QUIT
+39 ;
+40 IF '$DATA(^TMP("LA7S-RTM",$JOB))
Begin DoDot:1
+41 SET DIR("A",1)="No accessions found to retransmit."
+42 SET DIR("A")="Enter RETURN to continue or '^' to exit"
+43 SET DIR(0)="E"
+44 DO ^DIR
End DoDot:1
QUIT
+45 ;
+46 SET DIR("A")="Ready to retransmit"
+47 SET DIR("A",1)="Found "_LA7CNT_" accessions that can be retransmitted."
+48 SET DIR(0)="YO"
SET DIR("B")="NO"
+49 DO ^DIR
KILL DIR
+50 IF Y'=1
KILL ^TMP("LA7S-RTM",$JOB)
QUIT
+51 DO EN^DDIOL("Working","","!")
+52 ;
+53 KILL LA7Y
+54 SET LA7CNT=0
SET LA7UID=""
+55 FOR
SET LA7UID=$ORDER(^TMP("LA7S-RTM",$JOB,LA7UID))
if LA7UID=""
QUIT
Begin DoDot:1
+56 KILL LA7X,ZTSAVE
+57 SET LA7X=^TMP("LA7S-RTM",$JOB,LA7UID)
SET LA7CNT=LA7CNT+1
+58 SET ZTRTN="BUILD^LA7HDR"
SET ZTDTH=$HOROLOG
SET ZTIO=""
SET ZTDESC="Tasked Lab HL7 HDR ORU Build"
+59 SET ZTSAVE("LRAA")=$PIECE(LA7X,"^")
SET ZTSAVE("LRAD")=$PIECE(LA7X,"^",2)
SET ZTSAVE("LRAN")=$PIECE(LA7X,"^",3)
+60 SET ZTSAVE("LRDFN")=$PIECE(LA7X,"^",4)
SET ZTSAVE("LRSS")=$PIECE(LA7X,"^",5)
SET ZTSAVE("LRIDT")=$PIECE(LA7X,"^",6)
SET ZTSAVE("LA7MTYP")="ORU"
+61 IF $PIECE(LA7X,"^",5)="CH"
SET ZTSAVE("LRSPEC")=$PIECE(LA7X,"^",7)
+62 DO ^%ZTLOAD
+63 IF $GET(ZTSK)
Begin DoDot:2
+64 IF LA7CNT>101
QUIT
+65 IF LA7CNT=101
SET LA7Y(101)="*** Too many accessions to list (>100), list truncated... ***"
QUIT
+66 SET LA7Y(LA7CNT)="Task# "_ZTSK_" queued for processing accession "_LA7UID
End DoDot:2
+67 IF '$TEST
SET LA7Y(LA7CNT)="*** Tasking of retransmission failed for accession "_LA7UID_" ***"
End DoDot:1
+68 SET LA7Y(.1)="...Done"
SET LA7X(1,"F")=""
+69 SET LA7Y(.2)=LA7CNT_" accession"_$SELECT(LA7CNT>1:"s",1:"")_" scheduled for retransmitting of results!"
+70 DO EN^DDIOL(.LA7Y)
+71 KILL ^TMP("LA7S-RTM",$JOB)
+72 ;
+73 QUIT
+74 ;
+75 ;
SETTMP ;
+1 ;
+2 SET LA7UID=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^")
+3 IF LA7UID=""
QUIT
+4 SET LRDFN=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^")
+5 ; Quit if not a file #2 patient.
+6 IF $PIECE($GET(^LR(LRDFN,0)),"^",2)'=2
QUIT
+7 ; Quit if test patient on a production account.
+8 IF $$TESTPAT^VADPT($PIECE($GET(^LR(LRDFN,0)),"^",3))
IF LA7PROD
QUIT
+9 SET LRSS=$PIECE($GET(^LRO(68,LRAA,0)),"^",2)
SET LRIDT=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5)
+10 IF LRSS?1(1"CH",1"MI")
SET LRSPEC=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1)),"^")
+11 IF '$TEST
SET LRSPEC=""
+12 SET LA7CNT=LA7CNT+1
SET ^TMP("LA7S-RTM",$JOB,LA7UID)=LRAA_"^"_LRAD_"^"_LRAN_"^"_LRDFN_"^"_LRSS_"^"_LRIDT_"^"_LRSPEC
+13 QUIT
+14 ;
+15 ;
EXIT ;
+1 KILL LA7LIMIT
+2 DO CLEANUP^LA7QRY
DO EXIT^LA7VORM1
+3 KILL @GBL,^TMP("LA7VS",$JOB)
+4 QUIT
