HDISDOCL.m

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 ---HDISDOCL   11330     printed  Feb 18, 2025@23:22:51                                                                                                                                                                                                   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