HDISDOCL ;BPFO/DTG - COLLECT LABORTORY ITEMS FOR SDO LIST; Apr 07, 2018@12:42
;;1.0;HEALTH DATA & INFORMATICS;**22**;Feb 22, 2005;Build 26
;
; ICR's:
; 6901 - HDI READ LABORATORY SERVICE LABORATORY TEST FILE (#60)
; 6902 - HDI READ MASTER LABORATORY TEST FILE (#66.3)
;
Q
;
;bump tmp counter
BTMP() ;
N F
S F=$G(@TMP@(0)),F=F+1,@TMP@(0)=F
Q F
;
LEN ; lab entry point
;
; LAB TEST IEN, TEST NAME .01, TEST INACTIVE DATE 133, TEST INACTIVE STATUS 132, TEST TYPE 3,
; PANEL 200 SUB MULTIPLE, LOCATION DATA NAME #5,13, SITE/SPECIMEN 100, SITE/SPECIMEN IEN, R/S NAME .01,
; RESULT/SPECIMEN 33, R/S STATUS 32, MLTF PTR 30
; 66.3
; IEN, NAME .01, STATUS, LOINC CODE .04, ALT TEST NAME .02
;
N DA,DR,DIR,I,D,B,DIQ,DIC,ORDNM,ORIEN,ORIDT,ORST,PLIEN,PLNAME,PLPN,LT,LG,LB,LC,LRUN,LRIEN,LRNAME,LRMLIDT
N LRTYPE,LRDAT,LRDAP,LRSTAT,LRIDT,LRSPEC,LRSPN,LRSUN,LRSST,LRSIDT,LRMLTF,LRMLNM,LRMLAN,LRMLLON,LTMP,LRMLSTAT
N LRMLCOM,LRMLPROP,LRMLTIM,LRMLSPEC,LRMLSCAL,LRMLMET,L60,LPRI,LE,LF,PNLNN
N LTCNT,BA,LRAA,AA,AR,AB,ABC
; initialize vars to avoid undef
S (DA,DR,DIR,I,D,B,DIQ,DIC,ORDNM,ORIEN,ORIDT,ORST,PLIEN,PLNAME,PLPN,LT,LG,LB,LC,LRUN,LRIEN,LRNAME,LRMLIDT)=""
S (LRTYPE,LRDAT,LRDAP,LRSTAT,LRIDT,LRSPEC,LRSPN,LRSUN,LRSST,LRSIDT,LRMLTF,LRMLNM,LRMLAN,LRMLLON,LRMLSTAT)=""
S (LRMLCOM,LRMLPROP,LRMLTIM,LRMLSPEC,LRMLSCAL,LRMLMET,L60,LPRI,LE,LF)=""
; get info from 101.43
;
S L60=$$ORDI^HDISDOC(LAM),LPRI=L60
;
S (PLIEN,DA)=L60,PLPN="NO",LT="",LTMP="^TMP(""HDILAB1"",$J)" K @LTMP K DD
; check if 60 IEN
I 'L60 D G LQUIT
. S (PLIEN,PLNAME,PLPN)=""
. S (LRIEN,LRNAME,LRTYPE,LRDAT,LRDAP,LRIDT,LRSTAT)=""
. S (LRSPEC,LRSPN,LRSUN,LRSIDT,LRSST)=""
. S (LRMLTF,LRMLNM,LRMLAN,LRMLIDT,LRMLSTAT,LRMLLON,LRMLCOM,LRMLPROP,LRMLTIM,LRMLSPEC,LRMLSCAL,LRMLMET)=""
. D LH60P,LB60P,LH60T,LB60T,LH6001,LB6001,LH663,LB663,LT663,LT6001,LT60T
. S HDIERAR=HDIERAR_$S(HDIERAR'="":",",1:"")_8
. I $G(HDIERR)'="" S D=$G(@HDIERR@(0)),D=D+1,@HDIERR@(0)=D,@HDIERR@(D)="Orderable Item File Does Not Have a Lab File Number Associated. "_LAM_":"_ORDNM
;
S A=$$GET1^DIQ(60,L60_",",.01) I A="" D G LQUIT
. S (PLIEN,PLNAME,PLPN)=""
. S (LRIEN,LRNAME,LRTYPE,LRDAT,LRDAP,LRIDT,LRSTAT)=""
. S (LRSPEC,LRSPN,LRSUN,LRSIDT,LRSST)=""
. S (LRMLTF,LRMLNM,LRMLAN,LRMLIDT,LRMLSTAT,LRMLLON,LRMLCOM,LRMLPROP,LRMLTIM,LRMLSPEC,LRMLSCAL,LRMLMET)=""
. D LH60P,LB60P,LH60T,LB60T,LH6001,LB6001,LH663,LB663,LT663,LT6001,LT60T
. S HDIERAR=HDIERAR_$S(HDIERAR'="":",",1:"")_9
. I $G(HDIERR)'="" S D=$G(@HDIERR@(0)),D=D+1,@HDIERR@(0)=D,@HDIERR@(D)="Orderable Item Lab Pointer Not Found in Lab File. "_LAM_":"_ORDNM_":"_L60
;
;build array
; first determine if panel
K BA D LIST^DIC(60.02,","_L60_",","@;.01I","",,,,,,,"BA")
S A=$O(BA("DILIST","ID",0)) I A S PLPN="YES"
K PNLNN,BA
D PNLCK(PLIEN),GETLAB(PLIEN)
S PLNAME=$$CHKCHAR($G(LC(.01,"E")))
I $G(HDICNT)'="" D ;<
. S L=@HDICNT,K=$P(L,U,5),K=K+1,$P(L,U,5)=K
. I PLPN="YES" S K=$P(L,U,6),K=K+1,$P(L,U,6)=K
. S @HDICNT=L
D LH60P,LB60P
; go through the test array
S (LRIEN,LRNAME,LRTYPE,LRDAT,LRDAP,LRSTAT,LRIDT,LRSPEC,LRSPN,LRSUN,LRSST,LRSIDT,LRMLTF,LRMLNM,LRMLAN,LRMLSTAT)=""
S LRMLLON="N/F",(LRMLCOM,LRMLPROP,LRMLTIM,LRMLSPEC,LRMLSCAL,LRMLMET)=""
S A=$O(@LTMP@(0)) I 'A D G LQUIT
. S (LRIEN,LRNAME,LRTYPE,LRDAT,LRDAP,LRIDT,LRSTAT)=""
. S (LRSPEC,LRSPN,LRSUN,LRSIDT,LRSST)=""
. S (LRMLTF,LRMLNM,LRMLAN,LRMLIDT,LRMLSTAT,LRMLLON,LRMLCOM,LRMLPROP,LRMLTIM,LRMLSPEC,LRMLSCAL,LRMLMET)=""
. D LH60T,LB60T,LH6001,LB6001,LH663,LB663,LT663,LT6001,LT60T
;
S LRUN=0
LRT S LRUN=$O(@LTMP@(LRUN)) I 'LRUN G LQUIT
D GETLAB(LRUN) S LRIEN=LRUN,LRNAME=$$CHKCHAR($G(LC(.01,"E"))),LRTYPE=$G(LC(3,"E"))
S LRDAT=$G(LC(5,"I")),LRDAP=$G(LC(13,"I"))
S A=$G(LC(132,"I")),LRSTAT=$S(A="Y":1,1:0),A=$G(LC(133,"I")),LRIDT="" I A S LRIDT=$$FMTE^XLFDT(A,5)
I $G(HDICNT)'="" D ;<
. S L=@HDICNT,K=$P(L,U,7),K=K+1,$P(L,U,7)=K
. I LRIDT'="" S K=$P(L,U,8),K=K+1,$P(L,U,8)=K
. S @HDICNT=L
. ; collect unique tests for count
. S @TMPCT@("T",LRUN)=""
D LH60T,LB60T
; check specimens
S (LRSPEC,LRSPN,LRSUN,LRSST,LRSIDT,LRMLTF,LRMLNM,LRMLAN,LRMLSTAT,LRMLIDT)=""
S LRMLLON="N/F"
; S A=$$GET1^DIQ(60,L60_",",.01) I A="" D G LRT
K AA D LIST^DIC(60.01,","_LRUN_",","@;.001I","Q",,,,,,,"AA")
S A=0,A=$O(AA("DILIST",2,A)) I 'A D G LRT
. S (LRSPEC,LRSPN,LRSUN,LRSIDT,LRSST)=""
. S (LRMLTF,LRMLNM,LRMLAN,LRMLIDT,LRMLSTAT,LRMLLON,LRMLCOM,LRMLPROP,LRMLTIM,LRMLSPEC,LRMLSCAL,LRMLMET)=""
. D LH6001,LB6001,LH663,LB663,LT663,LT6001,LT60T
;
S LRSPEC=0
K LRAA S A=0 F S A=$O(AA("DILIST",2,A)) Q:'A S LRAA($G(AA("DILIST",2,A)))=""
LRS ;S LRSPEC=$O(^LAB(60,LRUN,1,LRSPEC)) I 'LRSPEC D LT60T G LRT
S LRSPEC=$O(LRAA(LRSPEC)) I 'LRSPEC D LT60T G LRT
D GETSPEC(LRUN,LRSPEC)
S LRSPN=$$CHKCHAR($G(LE(.01,"E"))),LRSUN=$G(LE(6,"E")),B=$G(LE(32,"I")),LRSST=$S(B="Y":1,1:"0")
S B=$G(LE(33,"I")),LRSIDT="" I B S LRSIDT=$$FMTE^XLFDT(B,5)
S LRMLTF=$G(LE(30,"I"))
I $G(HDICNT)'="" D ;<
. S L=@HDICNT,K=$P(L,U,9),K=K+1,$P(L,U,9)=K
. I LRSIDT'="" S K=$P(L,U,10),K=K+1,$P(L,U,10)=K
. S @HDICNT=L
D LH6001,LB6001
I LRMLTF D ;<
. D GETMLTF(LRMLTF)
. S LRMLNM=$$CHKCHAR($G(LF(.01,"E"))),LRMLAN=$$CHKCHAR($G(LF(.02,"E"))),LRMLLON=$G(LF(.04,"I")) S:LRMLLON="" LRMLLON="N/F"
. S LRMLCOM=$$CHKCHAR($G(LF(.05,"E"))),LRMLPROP=$$CHKCHAR($G(LF(.06,"E"))),LRMLTIM=$$CHKCHAR($G(LF(.07,"E")))
. S LRMLSPEC=$$CHKCHAR($G(LF(.08,"E"))),LRMLSCAL=$$CHKCHAR($G(LF(.09,"E"))),LRMLMET=$$CHKCHAR($G(LF(1,"E")))
. ; get status
. N DA,AA,LXH,A,B,C S DA=LRMLTF D LIST^DIC(66.399,","_DA_",","@;.01IE;.02IE","",,,,,,,"AA")
. K LXH M LXH=AA("DILIST","ID") K AA
. S A=$O(LXH(99999999),-1),B=$G(LXH(A,.02,"E")),C=$G(LXH(A,.01,"I"))
. S LRMLSTAT=0,LRMLIDT="" S LRMLSTAT=$S(B="INACTIVE":1,1:0) I LRMLSTAT S LRMLIDT=$$FMTE^XLFDT($P(C,".",1),5)
. I $G(HDICNT)'="" D ;<
. . S L=@HDICNT,K=$P(L,U,11),K=K+1,$P(L,U,11)=K
. . I LRMLIDT'="" S K=$P(L,U,12),K=K+1,$P(L,U,12)=K
. . S @HDICNT=L
. . ; get unique mltf items
. . S @TMPCT@("M",LRMLTF)=""
I 'LRMLTF S (LRMLTF,LRMLNM,LRMLAN,LRMLCOM,LRMLPROP,LRMLTIM,LRMLSPEC,LRMLSCAL,LRMLMET,LRMLIDT,LRMLSTAT,LRMLLON)=""
D LH663,LB663,LT663,LT6001
G LRS
;
LQUIT ; quit back
D LT60P,OT10143^HDISDOC
K @LTMP
K DA,DR,DIR,I,D,B,DIQ,DIC,ORDNM,ORIEN,ORIDT,ORST,PLIEN,PLNAME,PLPN,LT,LG,LB,LC,LRUN,LRIEN,LRNAME
K LRTYPE,LRDAT,LRDAP,LRSTAT,LRIDT,LRSPEC,LRSPN,LRSUN,LRSST,LRSIDT,LRMLTF,LRMLNM,LRMLAN,LRMLLON,LTMP
K LRMLCOM,LRMLPROP,LRMLTIM,LRMLSPEC,LRMLSCAL,LRMLMET,L60,LPRI,LE,LF,PNLNN
K LTCNT,BA,LRAA,AA,AR,AB,ABC
Q
;
PNLCK(LT) ; check for panel
N A,B,C,D,AA,AR,BA,BR S A=0
Q:'LT
S PNLNN(LT)=1
K AA D LIST^DIC(60.02,","_LT_",","@;.01I","",,,,,,,"AA")
K AR M AR=AA("DILIST","ID") K AA
S A=$O(AR(A)) I 'A S @LTMP@(LT)="" Q
S A=0 F S A=$O(AR(A)) Q:'A D ;<
. S C=$G(AR(A,.01)) Q:'C
. ; only have the test once for cycle of primary item
. I $G(PNLNN(C))=1 Q
. S PNLNN(C)=1
. K BA D LIST^DIC(60.02,","_C_",","@;.01I","",,,,,,,"BA")
. S B=$O(BA("DILIST","ID",0)) I B D PNLCK(C)
. S @LTMP@(C)=""
Q
;
CHKCHAR(A) ; check for ctrl chars, <, >, &, /
N B,C,I,L,M,N
I A="" Q A
S B="" F I=1:1:$L(A) S C=$E(A,I) D S L=C
. S M=$E(A,(I+1))
. I $A(C)<32!($A(C)>126) Q ; skip set
. I C="&" S N="'AND'",B=B_N Q
. I C="<" S N="'LESS THAN'",B=B_N Q
. I C=">" S N="'GREATER THAN'",B=B_N Q
. ;I C="/" S N="'FORWARD SLASH'",B=B_N Q
. S B=B_C
Q B
;
GETLAB(LG) ; get lab test info
N A,B,C,D,DA,DR,DIQ
Q:'LG
S DA=LG,DIQ="LB",DIQ(0)="IE",DIC=60,DR=".01;3;5;13;133;132" K ^UTILITY("DIQ1",$J) D EN^DIQ1 K ^UTILITY("DIQ1",$J)
K LC M LC=LB(60,DA) K LB
;
GETSPEC(LG,LS) ; get lab test specimen info
N A,B,C,D,DA,DR,DIQ
S DIQ="LB",DIQ(0)="IE",DIC=60,DR=100,DA=+LG K LB,^UTILITY("DIQ1",$J)
S DR(60.01)=".01;6;30;32;33",DA(60.01)=LS
D EN^DIQ1 K ^UTILITY("DIQ1",$J)
K LE M LE=LB("60.01",LS) K LB
Q
;
GETMLTF(LM) ; get mltf info from file 66.3
N A,B,C,D,DA,DR,DIQ
Q:'LM
S DA=LM,DIQ="LB",DIQ(0)="IE",DIC=66.3,DR=".01;.02;.04;.05;.06;.07;.08;.09;1" K ^UTILITY("DIQ1",$J) D EN^DIQ1 K ^UTILITY("DIQ1",$J)
K LF M LF=LB(66.3,DA) K LB
Q
;
LH60P ; header for primary item
S D=$$BTMP,@TMP@(D)="<Lab_Primary_Order_Item>"
Q
;
LT60P ; trailer for primary item
S D=$$BTMP,@TMP@(D)="</Lab_Primary_Order_Item>"
Q
;
LB60P ; body for primary item
S D=$$BTMP,@TMP@(D)="<Lab_Primary_Test_IEN>"_PLIEN_"</Lab_Primary_Test_IEN>"
S D=$$BTMP,@TMP@(D)="<Lab_Primary_Test_Name>"_PLNAME_"</Lab_Primary_Test_Name>"
S D=$$BTMP,@TMP@(D)="<Lab_Primary_Test_Panel>"_PLPN_"</Lab_Primary_Test_Panel>"
Q
;
LH60T ; test header for file 60
S D=$$BTMP,@TMP@(D)="<Laboratory_Test_Item>"
Q
;
LT60T ; test trailer for file 60
S D=$$BTMP,@TMP@(D)="</Laboratory_Test_Item>"
Q
;
LB60T ; test body for file 60
S D=$$BTMP,@TMP@(D)="<Lab_Test_IEN>"_LRIEN_"</Lab_Test_IEN>"
S D=$$BTMP,@TMP@(D)="<Lab_Test_Name>"_LRNAME_"</Lab_Test_Name>"
S D=$$BTMP,@TMP@(D)="<Lab_Test_Type>"_LRTYPE_"</Lab_Test_Type>"
S D=$$BTMP,@TMP@(D)="<Lab_Test_Data_Location>"_LRDAT_"</Lab_Test_Data_Location>"
S D=$$BTMP,@TMP@(D)="<Lab_Test_Data_Loc_Physical>"_LRDAP_"</Lab_Test_Data_Loc_Physical>"
S D=$$BTMP,@TMP@(D)="<Lab_Test_Inactive_Date>"_LRIDT_"</Lab_Test_Inactive_Date>"
S D=$$BTMP,@TMP@(D)="<Lab_Test_Status>"_LRSTAT_"</Lab_Test_Status>"
Q
;
LH6001 ; test specimen header for file 60.01
S D=$$BTMP,@TMP@(D)="<Lab_Test_Specimen>"
Q
;
LT6001 ; test specimen trailer for file 60.01
S D=$$BTMP,@TMP@(D)="</Lab_Test_Specimen>"
Q
;
LB6001 ; test spceimen body for file 60.01
S D=$$BTMP,@TMP@(D)="<Lab_Test_Specimen_IEN>"_LRSPEC_"</Lab_Test_Specimen_IEN>"
S D=$$BTMP,@TMP@(D)="<Lab_Test_Specimen_Name>"_LRSPN_"</Lab_Test_Specimen_Name>"
S D=$$BTMP,@TMP@(D)="<Lab_Test_Specimen_Units>"_LRSUN_"</Lab_Test_Specimen_Units>"
S D=$$BTMP,@TMP@(D)="<Lab_Test_Specimen_Inactive_Date>"_LRSIDT_"</Lab_Test_Specimen_Inactive_Date>"
S D=$$BTMP,@TMP@(D)="<Lab_Test_Specimen_Status>"_LRSST_"</Lab_Test_Specimen_Status>"
Q
;
LH663 ; header for mltf 66.3
S D=$$BTMP,@TMP@(D)="<Master_Lab_Test_Item>"
Q
;
LT663 ;trailer for mltf 66.3
S D=$$BTMP,@TMP@(D)="</Master_Lab_Test_Item>"
Q
;
LB663 ; body for mltf 66.3
S D=$$BTMP,@TMP@(D)="<Master_Lab_Test_IEN>"_LRMLTF_"</Master_Lab_Test_IEN>"
S D=$$BTMP,@TMP@(D)="<Master_Lab_Test_Name>"_LRMLNM_"</Master_Lab_Test_Name>"
S D=$$BTMP,@TMP@(D)="<Master_Lab_Test_Alternate_Name>"_LRMLAN_"</Master_Lab_Test_Alternate_Name>"
S D=$$BTMP,@TMP@(D)="<Master_Lab_Test_Inactive_Date>"_LRMLIDT_"</Master_Lab_Test_Inactive_Date>"
S D=$$BTMP,@TMP@(D)="<Master_Lab_Test_Status>"_LRMLSTAT_"</Master_Lab_Test_Status>"
S D=$$BTMP,@TMP@(D)="<Master_Lab_Test_LOINC_Code>"_LRMLLON_"</Master_Lab_Test_LOINC_Code>"
S D=$$BTMP,@TMP@(D)="<Master_Lab_Test_Component>"_LRMLCOM_"</Master_Lab_Test_Component>"
S D=$$BTMP,@TMP@(D)="<Master_Lab_Test_Property>"_LRMLPROP_"</Master_Lab_Test_Property>"
S D=$$BTMP,@TMP@(D)="<Master_Lab_Test_Time_Aspect>"_LRMLTIM_"</Master_Lab_Test_Time_Aspect>"
S D=$$BTMP,@TMP@(D)="<Master_Lab_Test_Specimen>"_LRMLSPEC_"</Master_Lab_Test_Specimen>"
S D=$$BTMP,@TMP@(D)="<Master_Lab_Test_Scale>"_LRMLSCAL_"</Master_Lab_Test_Scale>"
S D=$$BTMP,@TMP@(D)="<Master_Lab_Test_Method>"_LRMLMET_"</Master_Lab_Test_Method>"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHDISDOCL 11330 printed Sep 23, 2025@19:32:36 Page 2
HDISDOCL ;BPFO/DTG - COLLECT LABORTORY ITEMS FOR SDO LIST; Apr 07, 2018@12:42
+1 ;;1.0;HEALTH DATA & INFORMATICS;**22**;Feb 22, 2005;Build 26
+2 ;
+3 ; ICR's:
+4 ; 6901 - HDI READ LABORATORY SERVICE LABORATORY TEST FILE (#60)
+5 ; 6902 - HDI READ MASTER LABORATORY TEST FILE (#66.3)
+6 ;
+7 QUIT
+8 ;
+9 ;bump tmp counter
BTMP() ;
+1 NEW F
+2 SET F=$GET(@TMP@(0))
SET F=F+1
SET @TMP@(0)=F
+3 QUIT F
+4 ;
LEN ; lab entry point
+1 ;
+2 ; LAB TEST IEN, TEST NAME .01, TEST INACTIVE DATE 133, TEST INACTIVE STATUS 132, TEST TYPE 3,
+3 ; PANEL 200 SUB MULTIPLE, LOCATION DATA NAME #5,13, SITE/SPECIMEN 100, SITE/SPECIMEN IEN, R/S NAME .01,
+4 ; RESULT/SPECIMEN 33, R/S STATUS 32, MLTF PTR 30
+5 ; 66.3
+6 ; IEN, NAME .01, STATUS, LOINC CODE .04, ALT TEST NAME .02
+7 ;
+8 NEW DA,DR,DIR,I,D,B,DIQ,DIC,ORDNM,ORIEN,ORIDT,ORST,PLIEN,PLNAME,PLPN,LT,LG,LB,LC,LRUN,LRIEN,LRNAME,LRMLIDT
+9 NEW LRTYPE,LRDAT,LRDAP,LRSTAT,LRIDT,LRSPEC,LRSPN,LRSUN,LRSST,LRSIDT,LRMLTF,LRMLNM,LRMLAN,LRMLLON,LTMP,LRMLSTAT
+10 NEW LRMLCOM,LRMLPROP,LRMLTIM,LRMLSPEC,LRMLSCAL,LRMLMET,L60,LPRI,LE,LF,PNLNN
+11 NEW LTCNT,BA,LRAA,AA,AR,AB,ABC
+12 ; initialize vars to avoid undef
+13 SET (DA,DR,DIR,I,D,B,DIQ,DIC,ORDNM,ORIEN,ORIDT,ORST,PLIEN,PLNAME,PLPN,LT,LG,LB,LC,LRUN,LRIEN,LRNAME,LRMLIDT)=""
+14 SET (LRTYPE,LRDAT,LRDAP,LRSTAT,LRIDT,LRSPEC,LRSPN,LRSUN,LRSST,LRSIDT,LRMLTF,LRMLNM,LRMLAN,LRMLLON,LRMLSTAT)=""
+15 SET (LRMLCOM,LRMLPROP,LRMLTIM,LRMLSPEC,LRMLSCAL,LRMLMET,L60,LPRI,LE,LF)=""
+16 ; get info from 101.43
+17 ;
+18 SET L60=$$ORDI^HDISDOC(LAM)
SET LPRI=L60
+19 ;
+20 SET (PLIEN,DA)=L60
SET PLPN="NO"
SET LT=""
SET LTMP="^TMP(""HDILAB1"",$J)"
KILL @LTMP
KILL DD
+21 ; check if 60 IEN
+22 IF 'L60
Begin DoDot:1
+23 SET (PLIEN,PLNAME,PLPN)=""
+24 SET (LRIEN,LRNAME,LRTYPE,LRDAT,LRDAP,LRIDT,LRSTAT)=""
+25 SET (LRSPEC,LRSPN,LRSUN,LRSIDT,LRSST)=""
+26 SET (LRMLTF,LRMLNM,LRMLAN,LRMLIDT,LRMLSTAT,LRMLLON,LRMLCOM,LRMLPROP,LRMLTIM,LRMLSPEC,LRMLSCAL,LRMLMET)=""
+27 DO LH60P
DO LB60P
DO LH60T
DO LB60T
DO LH6001
DO LB6001
DO LH663
DO LB663
DO LT663
DO LT6001
DO LT60T
+28 SET HDIERAR=HDIERAR_$SELECT(HDIERAR'="":",",1:"")_8
+29 IF $GET(HDIERR)'=""
SET D=$GET(@HDIERR@(0))
SET D=D+1
SET @HDIERR@(0)=D
SET @HDIERR@(D)="Orderable Item File Does Not Have a Lab File Number Associated. "_LAM_":"_ORDNM
End DoDot:1
GOTO LQUIT
+30 ;
+31 SET A=$$GET1^DIQ(60,L60_",",.01)
IF A=""
Begin DoDot:1
+32 SET (PLIEN,PLNAME,PLPN)=""
+33 SET (LRIEN,LRNAME,LRTYPE,LRDAT,LRDAP,LRIDT,LRSTAT)=""
+34 SET (LRSPEC,LRSPN,LRSUN,LRSIDT,LRSST)=""
+35 SET (LRMLTF,LRMLNM,LRMLAN,LRMLIDT,LRMLSTAT,LRMLLON,LRMLCOM,LRMLPROP,LRMLTIM,LRMLSPEC,LRMLSCAL,LRMLMET)=""
+36 DO LH60P
DO LB60P
DO LH60T
DO LB60T
DO LH6001
DO LB6001
DO LH663
DO LB663
DO LT663
DO LT6001
DO LT60T
+37 SET HDIERAR=HDIERAR_$SELECT(HDIERAR'="":",",1:"")_9
+38 IF $GET(HDIERR)'=""
SET D=$GET(@HDIERR@(0))
SET D=D+1
SET @HDIERR@(0)=D
SET @HDIERR@(D)="Orderable Item Lab Pointer Not Found in Lab File. "_LAM_":"_ORDNM_":"_L60
End DoDot:1
GOTO LQUIT
+39 ;
+40 ;build array
+41 ; first determine if panel
+42 KILL BA
DO LIST^DIC(60.02,","_L60_",","@;.01I","",,,,,,,"BA")
+43 SET A=$ORDER(BA("DILIST","ID",0))
IF A
SET PLPN="YES"
+44 KILL PNLNN,BA
+45 DO PNLCK(PLIEN)
DO GETLAB(PLIEN)
+46 SET PLNAME=$$CHKCHAR($GET(LC(.01,"E")))
+47 ;<
IF $GET(HDICNT)'=""
Begin DoDot:1
+48 SET L=@HDICNT
SET K=$PIECE(L,U,5)
SET K=K+1
SET $PIECE(L,U,5)=K
+49 IF PLPN="YES"
SET K=$PIECE(L,U,6)
SET K=K+1
SET $PIECE(L,U,6)=K
+50 SET @HDICNT=L
End DoDot:1
+51 DO LH60P
DO LB60P
+52 ; go through the test array
+53 SET (LRIEN,LRNAME,LRTYPE,LRDAT,LRDAP,LRSTAT,LRIDT,LRSPEC,LRSPN,LRSUN,LRSST,LRSIDT,LRMLTF,LRMLNM,LRMLAN,LRMLSTAT)=""
+54 SET LRMLLON="N/F"
SET (LRMLCOM,LRMLPROP,LRMLTIM,LRMLSPEC,LRMLSCAL,LRMLMET)=""
+55 SET A=$ORDER(@LTMP@(0))
IF 'A
Begin DoDot:1
+56 SET (LRIEN,LRNAME,LRTYPE,LRDAT,LRDAP,LRIDT,LRSTAT)=""
+57 SET (LRSPEC,LRSPN,LRSUN,LRSIDT,LRSST)=""
+58 SET (LRMLTF,LRMLNM,LRMLAN,LRMLIDT,LRMLSTAT,LRMLLON,LRMLCOM,LRMLPROP,LRMLTIM,LRMLSPEC,LRMLSCAL,LRMLMET)=""
+59 DO LH60T
DO LB60T
DO LH6001
DO LB6001
DO LH663
DO LB663
DO LT663
DO LT6001
DO LT60T
End DoDot:1
GOTO LQUIT
+60 ;
+61 SET LRUN=0
LRT SET LRUN=$ORDER(@LTMP@(LRUN))
IF 'LRUN
GOTO LQUIT
+1 DO GETLAB(LRUN)
SET LRIEN=LRUN
SET LRNAME=$$CHKCHAR($GET(LC(.01,"E")))
SET LRTYPE=$GET(LC(3,"E"))
+2 SET LRDAT=$GET(LC(5,"I"))
SET LRDAP=$GET(LC(13,"I"))
+3 SET A=$GET(LC(132,"I"))
SET LRSTAT=$SELECT(A="Y":1,1:0)
SET A=$GET(LC(133,"I"))
SET LRIDT=""
IF A
SET LRIDT=$$FMTE^XLFDT(A,5)
+4 ;<
IF $GET(HDICNT)'=""
Begin DoDot:1
+5 SET L=@HDICNT
SET K=$PIECE(L,U,7)
SET K=K+1
SET $PIECE(L,U,7)=K
+6 IF LRIDT'=""
SET K=$PIECE(L,U,8)
SET K=K+1
SET $PIECE(L,U,8)=K
+7 SET @HDICNT=L
+8 ; collect unique tests for count
+9 SET @TMPCT@("T",LRUN)=""
End DoDot:1
+10 DO LH60T
DO LB60T
+11 ; check specimens
+12 SET (LRSPEC,LRSPN,LRSUN,LRSST,LRSIDT,LRMLTF,LRMLNM,LRMLAN,LRMLSTAT,LRMLIDT)=""
+13 SET LRMLLON="N/F"
+14 ; S A=$$GET1^DIQ(60,L60_",",.01) I A="" D G LRT
+15 KILL AA
DO LIST^DIC(60.01,","_LRUN_",","@;.001I","Q",,,,,,,"AA")
+16 SET A=0
SET A=$ORDER(AA("DILIST",2,A))
IF 'A
Begin DoDot:1
+17 SET (LRSPEC,LRSPN,LRSUN,LRSIDT,LRSST)=""
+18 SET (LRMLTF,LRMLNM,LRMLAN,LRMLIDT,LRMLSTAT,LRMLLON,LRMLCOM,LRMLPROP,LRMLTIM,LRMLSPEC,LRMLSCAL,LRMLMET)=""
+19 DO LH6001
DO LB6001
DO LH663
DO LB663
DO LT663
DO LT6001
DO LT60T
End DoDot:1
GOTO LRT
+20 ;
+21 SET LRSPEC=0
+22 KILL LRAA
SET A=0
FOR
SET A=$ORDER(AA("DILIST",2,A))
if 'A
QUIT
SET LRAA($GET(AA("DILIST",2,A)))=""
LRS ;S LRSPEC=$O(^LAB(60,LRUN,1,LRSPEC)) I 'LRSPEC D LT60T G LRT
+1 SET LRSPEC=$ORDER(LRAA(LRSPEC))
IF 'LRSPEC
DO LT60T
GOTO LRT
+2 DO GETSPEC(LRUN,LRSPEC)
+3 SET LRSPN=$$CHKCHAR($GET(LE(.01,"E")))
SET LRSUN=$GET(LE(6,"E"))
SET B=$GET(LE(32,"I"))
SET LRSST=$SELECT(B="Y":1,1:"0")
+4 SET B=$GET(LE(33,"I"))
SET LRSIDT=""
IF B
SET LRSIDT=$$FMTE^XLFDT(B,5)
+5 SET LRMLTF=$GET(LE(30,"I"))
+6 ;<
IF $GET(HDICNT)'=""
Begin DoDot:1
+7 SET L=@HDICNT
SET K=$PIECE(L,U,9)
SET K=K+1
SET $PIECE(L,U,9)=K
+8 IF LRSIDT'=""
SET K=$PIECE(L,U,10)
SET K=K+1
SET $PIECE(L,U,10)=K
+9 SET @HDICNT=L
End DoDot:1
+10 DO LH6001
DO LB6001
+11 ;<
IF LRMLTF
Begin DoDot:1
+12 DO GETMLTF(LRMLTF)
+13 SET LRMLNM=$$CHKCHAR($GET(LF(.01,"E")))
SET LRMLAN=$$CHKCHAR($GET(LF(.02,"E")))
SET LRMLLON=$GET(LF(.04,"I"))
if LRMLLON=""
SET LRMLLON="N/F"
+14 SET LRMLCOM=$$CHKCHAR($GET(LF(.05,"E")))
SET LRMLPROP=$$CHKCHAR($GET(LF(.06,"E")))
SET LRMLTIM=$$CHKCHAR($GET(LF(.07,"E")))
+15 SET LRMLSPEC=$$CHKCHAR($GET(LF(.08,"E")))
SET LRMLSCAL=$$CHKCHAR($GET(LF(.09,"E")))
SET LRMLMET=$$CHKCHAR($GET(LF(1,"E")))
+16 ; get status
+17 NEW DA,AA,LXH,A,B,C
SET DA=LRMLTF
DO LIST^DIC(66.399,","_DA_",","@;.01IE;.02IE","",,,,,,,"AA")
+18 KILL LXH
MERGE LXH=AA("DILIST","ID")
KILL AA
+19 SET A=$ORDER(LXH(99999999),-1)
SET B=$GET(LXH(A,.02,"E"))
SET C=$GET(LXH(A,.01,"I"))
+20 SET LRMLSTAT=0
SET LRMLIDT=""
SET LRMLSTAT=$SELECT(B="INACTIVE":1,1:0)
IF LRMLSTAT
SET LRMLIDT=$$FMTE^XLFDT($PIECE(C,".",1),5)
+21 ;<
IF $GET(HDICNT)'=""
Begin DoDot:2
+22 SET L=@HDICNT
SET K=$PIECE(L,U,11)
SET K=K+1
SET $PIECE(L,U,11)=K
+23 IF LRMLIDT'=""
SET K=$PIECE(L,U,12)
SET K=K+1
SET $PIECE(L,U,12)=K
+24 SET @HDICNT=L
+25 ; get unique mltf items
+26 SET @TMPCT@("M",LRMLTF)=""
End DoDot:2
End DoDot:1
+27 IF 'LRMLTF
SET (LRMLTF,LRMLNM,LRMLAN,LRMLCOM,LRMLPROP,LRMLTIM,LRMLSPEC,LRMLSCAL,LRMLMET,LRMLIDT,LRMLSTAT,LRMLLON)=""
+28 DO LH663
DO LB663
DO LT663
DO LT6001
+29 GOTO LRS
+30 ;
LQUIT ; quit back
+1 DO LT60P
DO OT10143^HDISDOC
+2 KILL @LTMP
+3 KILL DA,DR,DIR,I,D,B,DIQ,DIC,ORDNM,ORIEN,ORIDT,ORST,PLIEN,PLNAME,PLPN,LT,LG,LB,LC,LRUN,LRIEN,LRNAME
+4 KILL LRTYPE,LRDAT,LRDAP,LRSTAT,LRIDT,LRSPEC,LRSPN,LRSUN,LRSST,LRSIDT,LRMLTF,LRMLNM,LRMLAN,LRMLLON,LTMP
+5 KILL LRMLCOM,LRMLPROP,LRMLTIM,LRMLSPEC,LRMLSCAL,LRMLMET,L60,LPRI,LE,LF,PNLNN
+6 KILL LTCNT,BA,LRAA,AA,AR,AB,ABC
+7 QUIT
+8 ;
PNLCK(LT) ; check for panel
+1 NEW A,B,C,D,AA,AR,BA,BR
SET A=0
+2 if 'LT
QUIT
+3 SET PNLNN(LT)=1
+4 KILL AA
DO LIST^DIC(60.02,","_LT_",","@;.01I","",,,,,,,"AA")
+5 KILL AR
MERGE AR=AA("DILIST","ID")
KILL AA
+6 SET A=$ORDER(AR(A))
IF 'A
SET @LTMP@(LT)=""
QUIT
+7 ;<
SET A=0
FOR
SET A=$ORDER(AR(A))
if 'A
QUIT
Begin DoDot:1
+8 SET C=$GET(AR(A,.01))
if 'C
QUIT
+9 ; only have the test once for cycle of primary item
+10 IF $GET(PNLNN(C))=1
QUIT
+11 SET PNLNN(C)=1
+12 KILL BA
DO LIST^DIC(60.02,","_C_",","@;.01I","",,,,,,,"BA")
+13 SET B=$ORDER(BA("DILIST","ID",0))
IF B
DO PNLCK(C)
+14 SET @LTMP@(C)=""
End DoDot:1
+15 QUIT
+16 ;
CHKCHAR(A) ; check for ctrl chars, <, >, &, /
+1 NEW B,C,I,L,M,N
+2 IF A=""
QUIT A
+3 SET B=""
FOR I=1:1:$LENGTH(A)
SET C=$EXTRACT(A,I)
Begin DoDot:1
+4 SET M=$EXTRACT(A,(I+1))
+5 ; skip set
IF $ASCII(C)<32!($ASCII(C)>126)
QUIT
+6 IF C="&"
SET N="'AND'"
SET B=B_N
QUIT
+7 IF C="<"
SET N="'LESS THAN'"
SET B=B_N
QUIT
+8 IF C=">"
SET N="'GREATER THAN'"
SET B=B_N
QUIT
+9 ;I C="/" S N="'FORWARD SLASH'",B=B_N Q
+10 SET B=B_C
End DoDot:1
SET L=C
+11 QUIT B
+12 ;
GETLAB(LG) ; get lab test info
+1 NEW A,B,C,D,DA,DR,DIQ
+2 if 'LG
QUIT
+3 SET DA=LG
SET DIQ="LB"
SET DIQ(0)="IE"
SET DIC=60
SET DR=".01;3;5;13;133;132"
KILL ^UTILITY("DIQ1",$JOB)
DO EN^DIQ1
KILL ^UTILITY("DIQ1",$JOB)
+4 KILL LC
MERGE LC=LB(60,DA)
KILL LB
+5 ;
GETSPEC(LG,LS) ; get lab test specimen info
+1 NEW A,B,C,D,DA,DR,DIQ
+2 SET DIQ="LB"
SET DIQ(0)="IE"
SET DIC=60
SET DR=100
SET DA=+LG
KILL LB,^UTILITY("DIQ1",$JOB)
+3 SET DR(60.01)=".01;6;30;32;33"
SET DA(60.01)=LS
+4 DO EN^DIQ1
KILL ^UTILITY("DIQ1",$JOB)
+5 KILL LE
MERGE LE=LB("60.01",LS)
KILL LB
+6 QUIT
+7 ;
GETMLTF(LM) ; get mltf info from file 66.3
+1 NEW A,B,C,D,DA,DR,DIQ
+2 if 'LM
QUIT
+3 SET DA=LM
SET DIQ="LB"
SET DIQ(0)="IE"
SET DIC=66.3
SET DR=".01;.02;.04;.05;.06;.07;.08;.09;1"
KILL ^UTILITY("DIQ1",$JOB)
DO EN^DIQ1
KILL ^UTILITY("DIQ1",$JOB)
+4 KILL LF
MERGE LF=LB(66.3,DA)
KILL LB
+5 QUIT
+6 ;
LH60P ; header for primary item
+1 SET D=$$BTMP
SET @TMP@(D)="<Lab_Primary_Order_Item>"
+2 QUIT
+3 ;
LT60P ; trailer for primary item
+1 SET D=$$BTMP
SET @TMP@(D)="</Lab_Primary_Order_Item>"
+2 QUIT
+3 ;
LB60P ; body for primary item
+1 SET D=$$BTMP
SET @TMP@(D)="<Lab_Primary_Test_IEN>"_PLIEN_"</Lab_Primary_Test_IEN>"
+2 SET D=$$BTMP
SET @TMP@(D)="<Lab_Primary_Test_Name>"_PLNAME_"</Lab_Primary_Test_Name>"
+3 SET D=$$BTMP
SET @TMP@(D)="<Lab_Primary_Test_Panel>"_PLPN_"</Lab_Primary_Test_Panel>"
+4 QUIT
+5 ;
LH60T ; test header for file 60
+1 SET D=$$BTMP
SET @TMP@(D)="<Laboratory_Test_Item>"
+2 QUIT
+3 ;
LT60T ; test trailer for file 60
+1 SET D=$$BTMP
SET @TMP@(D)="</Laboratory_Test_Item>"
+2 QUIT
+3 ;
LB60T ; test body for file 60
+1 SET D=$$BTMP
SET @TMP@(D)="<Lab_Test_IEN>"_LRIEN_"</Lab_Test_IEN>"
+2 SET D=$$BTMP
SET @TMP@(D)="<Lab_Test_Name>"_LRNAME_"</Lab_Test_Name>"
+3 SET D=$$BTMP
SET @TMP@(D)="<Lab_Test_Type>"_LRTYPE_"</Lab_Test_Type>"
+4 SET D=$$BTMP
SET @TMP@(D)="<Lab_Test_Data_Location>"_LRDAT_"</Lab_Test_Data_Location>"
+5 SET D=$$BTMP
SET @TMP@(D)="<Lab_Test_Data_Loc_Physical>"_LRDAP_"</Lab_Test_Data_Loc_Physical>"
+6 SET D=$$BTMP
SET @TMP@(D)="<Lab_Test_Inactive_Date>"_LRIDT_"</Lab_Test_Inactive_Date>"
+7 SET D=$$BTMP
SET @TMP@(D)="<Lab_Test_Status>"_LRSTAT_"</Lab_Test_Status>"
+8 QUIT
+9 ;
LH6001 ; test specimen header for file 60.01
+1 SET D=$$BTMP
SET @TMP@(D)="<Lab_Test_Specimen>"
+2 QUIT
+3 ;
LT6001 ; test specimen trailer for file 60.01
+1 SET D=$$BTMP
SET @TMP@(D)="</Lab_Test_Specimen>"
+2 QUIT
+3 ;
LB6001 ; test spceimen body for file 60.01
+1 SET D=$$BTMP
SET @TMP@(D)="<Lab_Test_Specimen_IEN>"_LRSPEC_"</Lab_Test_Specimen_IEN>"
+2 SET D=$$BTMP
SET @TMP@(D)="<Lab_Test_Specimen_Name>"_LRSPN_"</Lab_Test_Specimen_Name>"
+3 SET D=$$BTMP
SET @TMP@(D)="<Lab_Test_Specimen_Units>"_LRSUN_"</Lab_Test_Specimen_Units>"
+4 SET D=$$BTMP
SET @TMP@(D)="<Lab_Test_Specimen_Inactive_Date>"_LRSIDT_"</Lab_Test_Specimen_Inactive_Date>"
+5 SET D=$$BTMP
SET @TMP@(D)="<Lab_Test_Specimen_Status>"_LRSST_"</Lab_Test_Specimen_Status>"
+6 QUIT
+7 ;
LH663 ; header for mltf 66.3
+1 SET D=$$BTMP
SET @TMP@(D)="<Master_Lab_Test_Item>"
+2 QUIT
+3 ;
LT663 ;trailer for mltf 66.3
+1 SET D=$$BTMP
SET @TMP@(D)="</Master_Lab_Test_Item>"
+2 QUIT
+3 ;
LB663 ; body for mltf 66.3
+1 SET D=$$BTMP
SET @TMP@(D)="<Master_Lab_Test_IEN>"_LRMLTF_"</Master_Lab_Test_IEN>"
+2 SET D=$$BTMP
SET @TMP@(D)="<Master_Lab_Test_Name>"_LRMLNM_"</Master_Lab_Test_Name>"
+3 SET D=$$BTMP
SET @TMP@(D)="<Master_Lab_Test_Alternate_Name>"_LRMLAN_"</Master_Lab_Test_Alternate_Name>"
+4 SET D=$$BTMP
SET @TMP@(D)="<Master_Lab_Test_Inactive_Date>"_LRMLIDT_"</Master_Lab_Test_Inactive_Date>"
+5 SET D=$$BTMP
SET @TMP@(D)="<Master_Lab_Test_Status>"_LRMLSTAT_"</Master_Lab_Test_Status>"
+6 SET D=$$BTMP
SET @TMP@(D)="<Master_Lab_Test_LOINC_Code>"_LRMLLON_"</Master_Lab_Test_LOINC_Code>"
+7 SET D=$$BTMP
SET @TMP@(D)="<Master_Lab_Test_Component>"_LRMLCOM_"</Master_Lab_Test_Component>"
+8 SET D=$$BTMP
SET @TMP@(D)="<Master_Lab_Test_Property>"_LRMLPROP_"</Master_Lab_Test_Property>"
+9 SET D=$$BTMP
SET @TMP@(D)="<Master_Lab_Test_Time_Aspect>"_LRMLTIM_"</Master_Lab_Test_Time_Aspect>"
+10 SET D=$$BTMP
SET @TMP@(D)="<Master_Lab_Test_Specimen>"_LRMLSPEC_"</Master_Lab_Test_Specimen>"
+11 SET D=$$BTMP
SET @TMP@(D)="<Master_Lab_Test_Scale>"_LRMLSCAL_"</Master_Lab_Test_Scale>"
+12 SET D=$$BTMP
SET @TMP@(D)="<Master_Lab_Test_Method>"_LRMLMET_"</Master_Lab_Test_Method>"
+13 QUIT
