HDISDOC ;BPFO/DTG - COMPILE SDO LIST FROM 101.43; Apr 07, 2018@12:42
;;1.0;HEALTH DATA & INFORMATICS;**22**;Feb 22, 2005;Build 26
;
; ICR's:
; 6895 - HDI READ ORDERABLE ITEMS File (#101.43)
; 6901 - HDI READ LABORATORY SERVICE LABORATORY TEST FILE (#60)
; 6902 - HDI READ MASTER LABORATORY TEST FILE (#66.3)
;
; 1131 - XMB('NETNAME')
;
; This routine collects and returns the SDO's associated to items in the orderable item file 101.43
;
; HDIAREA - Search area 'L' for LAB
; HDITYPE - Type of lookup 'S' for Single, 'P' for Partial Match, 'ALL' for ALL items
; HDIOIEN - may be one of 3 values. A) the IEN for a select item from the 101.43
; B) the word 'ALL' for all items for the HDIAREA selected
; C) a partial match to a 101.43 terms name. this is to collect
; 101.43 items that partial match the name passed in and are
; associated to the HDIAREA.
; HDIRET - this is the return array in XML form.
; HDIERR - (optional) If defined, If there is an error then it is set to a number
; 1 - area not sent. 2 - lookup value not sent. 3 - return value not sent.
; 4 - Improper Search Area
; 5 - single item not found in 101.43.
; 6 - single item not in area.
; 7 - Partial Lookup Error.
; 8 - Orderable Items File Does Not Have Lab Pointer for Item.
; 9 - Orderable Item Lab Pointer Not Found in Lab File.
; 10 -
; 11 -
; 12 - Lookup type not sent
;
; HDICNT - This will contain counts of the various orders
; Area - L. The return will be different based on the area.
;
; Laboratory L ^ Orderable Item Count (#101.43) ^ Number of Orderable Items Inactive
; ^ Number of Mnemonics ^ Number of Primary Lab Tests (#60)
; ^ Number of Primary Tests are Panels ^ Total Number of Tests (#60) ^ Number of Inactive tests
; ^ Total Number of Specimens (#60, #100) ^ number of inactive specimens
; ^ Number of Master Laboratory Tests (#66.3) ^ number of inactive MLTF's ^ number of unique tests referenced
; ^ number of unique MLTF items referenced
;
; HDIMN This is for further delineation of a 'SINGLE' look-up. If the Single item is identified as
; an mnemonic by the calling routine the value would be 'Y' for yes.
;
N MSG
S MSG(1)=" This option may not be called directly from the menu options"
S MSG(2)=" Please use option HDI REQUEST SDO."
S MSG(3)=""
D CLEAR^VALM1
D BMES^XPDUTL(.MSG)
K MSG
Q
;
;
EN(HDIAREA,HDITYPE,HDIOIEN,HDIRET,HDIERR,HDICNT,HDIMN) ; entry for lookup
I $G(DT)="" S DT=$$DT^XLFDT
I $G(U)="" S U="^"
N A,B,C,D,E,F,G,I,DA,DR,ROOT,TMP,LAB,PHM,NAR,OK,XHEAD,WB,ORMN,PART,LKUP,O,LAM,RAM,PAM,OIC,OICI
N ORDNM,ORIDT,ORIEN,ORST,DIC,DIQ,K,L,TMPCT,HDIERAR
N HDIA1,HDIA2
S A=$$SITE^VASITE,WB=$P(A,U,2)_"-"_$P(A,U,1),OIC=0,OICI=0,HDIERAR=""
S HDIA1="^TMP(""HDIA1"",$J)",HDIA2="^TMP(""HDIA2"",$J)"
I $G(HDIAREA)="" S HDIERAR=1 ; quit if no area selected
I $G(HDITYPE)="" S HDIERAR=HDIERAR_$S(HDIERAR'="":",",1:"")_12 ; quit if no lookup value is sent
I $G(HDIOIEN)="" S HDIERAR=HDIERAR_$S(HDIERAR'="":",",1:"")_2 ; quit if no lookup value is sent
I $G(HDIRET)="" S HDIERAR=HDIERAR_$S(HDIERAR'="":",",1:"")_3 ; quit if return array is not defined
I HDIERAR'="" Q HDIERAR
;
K ^TMP("HDISDOLIST",$J),^TMP("HDITMCT",$J)
S TMPCT="^TMP(""HDITMCT"",$J)"
S TMP="^TMP(""HDISDOLIST"",$J)",@TMP@(0)=0
S A=$$UP^XLFSTR(HDIAREA),ORMN="",HDIAREA=A
S NAR=$S($E(A)="L":"LAB",1:"")
I NAR="" S HDIERAR=HDIERAR_$S(HDIERAR'="":",",1:"")_4 Q HDIERAR ; proper area not selected
I $G(HDICNT)'="" S @HDICNT=A
;xml header
S XHEAD=$S(NAR="LAB":"Laboratory",1:"no area")_"_Orderable_Items",B="xmlns:xs="
S @TMP@(0)=0
S D=$$BTMP,@TMP@(D)=$$XMLHDR^MXMLUTL()
S D=$$BTMP,@TMP@(D)="<"_XHEAD_" "_B_"""http://www.w3.org/2001/XMLSchema"">"
S D=$$BTMP,@TMP@(D)="<Facility>"
S D=$$BTMP,@TMP@(D)="<Facility_Name-Number>"_WB_"</Facility_Name-Number>"
S A=$$PROD^XUPROD(),B=$S(A="1":"YES",1:"NO"),D=$$BTMP,@TMP@(D)="<Facility_Production_Account>"_B_"</Facility_Production_Account>"
S A=$G(^XMB("NETNAME"))
S LKUP=$S($E(HDITYPE,1)="S":"SINGLE",$E(HDITYPE,1)="P":"PARTIAL",HDITYPE="ALL":"ALL",1:"")
S D=$$BTMP,@TMP@(D)="<Facility_Net_Name>"_A_"</Facility_Net_Name>"
S D=$$BTMP,@TMP@(D)="<Look_up_Type>"_LKUP_"</Look_up_Type>"
I LKUP="PARTIAL" S D=$$BTMP,@TMP@(D)="<Look_up_Partial_Name>"_HDIOIEN_"</Look_up_Partial_Name>"
S D=$$BTMP,@TMP@(D)="</Facility>"
I LKUP="" S D=$$BTMP,@TMP@(D)="<Look_up_Type_Error>Look up Type: "_HDIOIEN_", not Identified</Look_up_Type_Error>" G OUT
;
; set up allowable sets by area
F I="RX","O RX","UD RX","NV RX","IVA RX","IVB RX","IVM RX","I RX" S PHM(I)=1
F I="LAB","CH","MI","EM","SP","CY","AU" S LAB(I)=1
;set up if XML
;
I HDIOIEN="ALL" G ALL
I HDIOIEN?1N.N S A=$$GET1^DIQ(101.43,HDIOIEN_",",.01) I A'="" G IEN
; test names may start with alpha, numeric, punctuation.
G PARTIAL
Q
;
ALL ; get all items for an area
K @HDIA1,@HDIA2
D LIST^DIC(101.43,,"@;.001I","MUQ",,,,,,,HDIA1)
S A=0 F S A=$O(@HDIA1@("DILIST",2,A)) Q:'A S B=$G(@HDIA1@("DILIST",2,A)),@HDIA2@(B)=""
K @HDIA1
S HDIOIEN=0
A1 S HDIOIEN=$O(@HDIA2@(HDIOIEN)) I 'HDIOIEN K @HDIA2 G OUT
;check that orderable item is for the area
S OK=$$CHKO(HDIOIEN)
I 'OK G A1
I NAR="LAB" D LAB(HDIOIEN)
G A1
;
PARTIAL ; get items that partial match the name sent
S PART=HDIOIEN K ^TMP("HDICHK",$J)
K @HDIA1,@HDIA2
; this will pick up those items with mnemonics that are related to the partial name sent in.
; since a orderable name and its mnemonic can start the same place into a temp area to reduce duplication.
D LIST^DIC(101.43,,";.01I","",,,PART,"B",,,HDIA1)
S A=0 F S A=$O(@HDIA1@("DILIST",2,A)) Q:'A D ;<
. S D=$G(@HDIA1@("DILIST",2,A)),E=$G(@HDIA1@("DILIST",1,A)),F=$G(@HDIA1@("DILIST","ID",A,.01))
. S B=$S(((E'=F)&($E(F,1,$L(PART))'=PART)):1,1:"")
. S:'$D(@HDIA2@(D)) @HDIA2@(D)=B
K @HDIA1
S A=0
P1A S A=$O(@HDIA2@(A)) I 'A G P2
; make sure the item is for the correct area.
S OK=$$CHKO(A)
I 'OK D ;<
. K @HDIA2@(A)
G P1A
;
P2 I $O(@HDIA2@(0))="" D G OUT
. S HDIERAR=HDIERAR_$S(HDIERAR'="":",",1:"")_7
. I $G(HDIERR)'="" S D=$G(@HDIERR@(0)),D=D+1,@HDIERR@(0)=D,@HDIERR@(D)="Partial_lookup_Error. Partial Name: "_PART_", not found for Area: "_NAR
S HDIOIEN=0
P2A S HDIOIEN=$O(@HDIA2@(HDIOIEN)) I 'HDIOIEN K @HDIA2 G OUT
S ORMN=$S($G(@HDIA2@(HDIOIEN))=1:"YES",1:"")
I NAR="LAB" D LAB(HDIOIEN)
G P2A
;
IEN ; find entry for a single IEN in 101.43
S D=$$GET1^DIQ(101.43,HDIOIEN_",",.01) I D="" S HDIERAR=HDIERAR_$S(HDIERAR'="":",",1:"")_5 D G OUT
. I $G(HDIERR)'="" S D=$G(@HDIERR@(0)),D=D+1,@HDIERR@(0)=D,@HDIERR@(D)="Single_Lookup_Error ("_$G(HDIOIEN)_") Entry Not Found in Orderable Items File"
; quit on first good
S OK=$$CHKO(HDIOIEN)
I 'OK S HDIERAR=HDIERAR_$S(HDIERAR'="":",",1:"")_6 D G OUT
. I $G(HDIERR)'="" S D=$G(@HDIERR@(0)),D=D+1,@HDIERR@(0)=D,@HDIERR@(D)="Single_Lookup_Error ("_$G(HDIOIEN)_") Entry Not Found in Orderable Items File"
I $G(HDIMN)="Y" S ORMN="YES"
I NAR="LAB" D LAB(HDIOIEN)
G OUT
;
OUT ; return to calling routine
S D=$$BTMP,@TMP@(D)="</"_XHEAD_">"
I $G(HDICNT)'="" D ;<
. I NAR="LAB" D ;<
. . N A,B,C S (A,B)=0 F S A=$O(@TMPCT@("T",A)) Q:'A S B=B+1
. . S L=@HDICNT,$P(L,U,13)=B
. . S (A,B)=0 F S A=$O(@TMPCT@("M",A)) Q:'A S B=B+1
. . I B S $P(L,U,14)=B
. . S @HDICNT=L
K @HDIRET
M @HDIRET=@TMP
K @TMP
K A,B,C,D,E,F,G,I,DA,DR,ROOT,TMP,LAB,PHM,NAR,OK,XHEAD,WB,ORMN,PART,LKUP,O,LAM,RAM,PAM
K ORDNM,ORIDT,ORIEN,ORST,DIC,DIQ
K HDIA1,HDIA2
I HDIERAR'="" Q HDIERAR
Q "0"
Q
;
LAB(LAM) ;get laboratory SDO's
;
G LEN^HDISDOCL
;
ORDI(A) ; get info from 101.43
S DA=A
N OA,OB,B,C,D,E,F,O,R,K,M,AAA,AAB,AAC,AAD
S C="",DIQ="OB",DIQ(0)="IE",DIC=101.43,DR=".01;2;.1" K ^UTILITY("DIQ1",$J) D EN^DIQ1 K ^UTILITY("DIQ1",$J)
K OA M OA=OB(101.43,DA) K OB
S ORDNM=$$CHKCHAR($G(OA(.01,"E"))),B=$G(OA(.1,"I")),ORIEN=DA,C=$P($G(OA(2,"I")),";",1)
S ORIDT="",ORST=0 S:(B&(B<DT+1)) ORST=1 S:B ORIDT=$$FMTE^XLFDT($P(B,".",1),5)
I $G(HDICNT)'="" D ;<
. S L=@HDICNT,K=$P(L,U,2),K=K+1,$P(L,U,2)=K
. I ORIDT'="" S K=$P(L,U,3),K=K+1,$P(L,U,3)=K
. I ORMN'="" S K=$P(L,U,4),K=K+1,$P(L,U,4)=K
. S @HDICNT=L
; set up order info if XML
S OIC=OIC+1
S D=$$BTMP,@TMP@(D)="<Orderable_Item>"
S D=$$BTMP,@TMP@(D)="<Orderable_Item_Number>"_ORIEN_"</Orderable_Item_Number>"
S D=$$BTMP,@TMP@(D)="<Orderable_Item_Name>"_ORDNM_"</Orderable_Item_Name>"
S D=$$BTMP,@TMP@(D)="<Orderable_Item_Mnemonic>"_ORMN_"</Orderable_Item_Mnemonic>"
S D=$$BTMP,@TMP@(D)="<Orderable_Item_Inactive_Date>"_ORIDT_"</Orderable_Item_Inactive_Date>"
S D=$$BTMP,@TMP@(D)="<Orderable_Item_Status>"_ORST_"</Orderable_Item_Status>"
; add in the synonym's
S D=$$BTMP,@TMP@(D)="<Orderable_Item_Synonym>"
K AAA D LIST^DIC(101.432,","_DA_",","@;.01I","",,,,,,,"AAA")
K AAB,AAC,AAD M AAB=AAA("DILIST","ID"),AAD=AAA("DILIST",2)
S M=0 F S M=$O(AAD(M)) Q:'M S F=$G(AAD(M)),AAC(F)=$G(AAB(M,.01))
S O=0 F S O=$O(AAC(O)) Q:'O S R=$$CHKCHAR($G(AAC(O))) D ;<
. S D=$$BTMP,@TMP@(D)="<Orderable_Item_Synonym_Name>"_R_"</Orderable_Item_Synonym_Name>"
S D=$$BTMP,@TMP@(D)="</Orderable_Item_Synonym>"
K AAA,AAB,AAC,AAD
Q C
;
;bump tmp counter
BTMP() ;
N F
S F=$G(@TMP@(0)),F=F+1,@TMP@(0)=F
Q F
;
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
. S B=B_C
Q B
;
OH10143 ;header 101.43
S D=$$BTMP,@TMP@(D)="<Orderable_Item>"
Q
;
OT10143 ; trailer for 101.43
S D=$$BTMP,@TMP@(D)="</Orderable_Item>"
Q
;
OB10143 ; body for 101.43
S D=$$BTMP,@TMP@(D)="<Orderable_Item_Number>"_ORIEN_"</Orderable_Item_Number>"
S D=$$BTMP,@TMP@(D)="<Orderable_Item_Name>"_ORDNM_"</Orderable_Item_Name>"
S D=$$BTMP,@TMP@(D)="<Orderable_Item_Inactive_Date>"_ORIDT_"</Orderable_Item_Inactive_Date>"
S D=$$BTMP,@TMP@(D)="<Orderable_Item_Status>"_ORST_"</Orderable_Item_Status>"
Q
;
CHKO(HOI) ;check if order belongs to the correct area
N A,B,AA,AR,E
S OK="" K AA D LIST^DIC(101.439,","_HOI_",","@;.01I","",,,,,,,"AA")
K AR M AR=AA("DILIST","ID") K AA
S E="" F S E=$O(AR(E)) Q:'E S B=$G(AR(E,.01)) S:$G(@NAR@(B))=1 OK=1 I (HDIAREA="L"&((B="BB")!(B="HEMA")!(B="AP")!(B="VBC")!(B="VBEC")!(B="Hemo"))) S OK="" Q
K AR,A,B,AA,E
Q OK
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHDISDOC 10822 printed Oct 16, 2024@17:57:18 Page 2
HDISDOC ;BPFO/DTG - COMPILE SDO LIST FROM 101.43; Apr 07, 2018@12:42
+1 ;;1.0;HEALTH DATA & INFORMATICS;**22**;Feb 22, 2005;Build 26
+2 ;
+3 ; ICR's:
+4 ; 6895 - HDI READ ORDERABLE ITEMS File (#101.43)
+5 ; 6901 - HDI READ LABORATORY SERVICE LABORATORY TEST FILE (#60)
+6 ; 6902 - HDI READ MASTER LABORATORY TEST FILE (#66.3)
+7 ;
+8 ; 1131 - XMB('NETNAME')
+9 ;
+10 ; This routine collects and returns the SDO's associated to items in the orderable item file 101.43
+11 ;
+12 ; HDIAREA - Search area 'L' for LAB
+13 ; HDITYPE - Type of lookup 'S' for Single, 'P' for Partial Match, 'ALL' for ALL items
+14 ; HDIOIEN - may be one of 3 values. A) the IEN for a select item from the 101.43
+15 ; B) the word 'ALL' for all items for the HDIAREA selected
+16 ; C) a partial match to a 101.43 terms name. this is to collect
+17 ; 101.43 items that partial match the name passed in and are
+18 ; associated to the HDIAREA.
+19 ; HDIRET - this is the return array in XML form.
+20 ; HDIERR - (optional) If defined, If there is an error then it is set to a number
+21 ; 1 - area not sent. 2 - lookup value not sent. 3 - return value not sent.
+22 ; 4 - Improper Search Area
+23 ; 5 - single item not found in 101.43.
+24 ; 6 - single item not in area.
+25 ; 7 - Partial Lookup Error.
+26 ; 8 - Orderable Items File Does Not Have Lab Pointer for Item.
+27 ; 9 - Orderable Item Lab Pointer Not Found in Lab File.
+28 ; 10 -
+29 ; 11 -
+30 ; 12 - Lookup type not sent
+31 ;
+32 ; HDICNT - This will contain counts of the various orders
+33 ; Area - L. The return will be different based on the area.
+34 ;
+35 ; Laboratory L ^ Orderable Item Count (#101.43) ^ Number of Orderable Items Inactive
+36 ; ^ Number of Mnemonics ^ Number of Primary Lab Tests (#60)
+37 ; ^ Number of Primary Tests are Panels ^ Total Number of Tests (#60) ^ Number of Inactive tests
+38 ; ^ Total Number of Specimens (#60, #100) ^ number of inactive specimens
+39 ; ^ Number of Master Laboratory Tests (#66.3) ^ number of inactive MLTF's ^ number of unique tests referenced
+40 ; ^ number of unique MLTF items referenced
+41 ;
+42 ; HDIMN This is for further delineation of a 'SINGLE' look-up. If the Single item is identified as
+43 ; an mnemonic by the calling routine the value would be 'Y' for yes.
+44 ;
+45 NEW MSG
+46 SET MSG(1)=" This option may not be called directly from the menu options"
+47 SET MSG(2)=" Please use option HDI REQUEST SDO."
+48 SET MSG(3)=""
+49 DO CLEAR^VALM1
+50 DO BMES^XPDUTL(.MSG)
+51 KILL MSG
+52 QUIT
+53 ;
+54 ;
EN(HDIAREA,HDITYPE,HDIOIEN,HDIRET,HDIERR,HDICNT,HDIMN) ; entry for lookup
+1 IF $GET(DT)=""
SET DT=$$DT^XLFDT
+2 IF $GET(U)=""
SET U="^"
+3 NEW A,B,C,D,E,F,G,I,DA,DR,ROOT,TMP,LAB,PHM,NAR,OK,XHEAD,WB,ORMN,PART,LKUP,O,LAM,RAM,PAM,OIC,OICI
+4 NEW ORDNM,ORIDT,ORIEN,ORST,DIC,DIQ,K,L,TMPCT,HDIERAR
+5 NEW HDIA1,HDIA2
+6 SET A=$$SITE^VASITE
SET WB=$PIECE(A,U,2)_"-"_$PIECE(A,U,1)
SET OIC=0
SET OICI=0
SET HDIERAR=""
+7 SET HDIA1="^TMP(""HDIA1"",$J)"
SET HDIA2="^TMP(""HDIA2"",$J)"
+8 ; quit if no area selected
IF $GET(HDIAREA)=""
SET HDIERAR=1
+9 ; quit if no lookup value is sent
IF $GET(HDITYPE)=""
SET HDIERAR=HDIERAR_$SELECT(HDIERAR'="":",",1:"")_12
+10 ; quit if no lookup value is sent
IF $GET(HDIOIEN)=""
SET HDIERAR=HDIERAR_$SELECT(HDIERAR'="":",",1:"")_2
+11 ; quit if return array is not defined
IF $GET(HDIRET)=""
SET HDIERAR=HDIERAR_$SELECT(HDIERAR'="":",",1:"")_3
+12 IF HDIERAR'=""
QUIT HDIERAR
+13 ;
+14 KILL ^TMP("HDISDOLIST",$JOB),^TMP("HDITMCT",$JOB)
+15 SET TMPCT="^TMP(""HDITMCT"",$J)"
+16 SET TMP="^TMP(""HDISDOLIST"",$J)"
SET @TMP@(0)=0
+17 SET A=$$UP^XLFSTR(HDIAREA)
SET ORMN=""
SET HDIAREA=A
+18 SET NAR=$SELECT($EXTRACT(A)="L":"LAB",1:"")
+19 ; proper area not selected
IF NAR=""
SET HDIERAR=HDIERAR_$SELECT(HDIERAR'="":",",1:"")_4
QUIT HDIERAR
+20 IF $GET(HDICNT)'=""
SET @HDICNT=A
+21 ;xml header
+22 SET XHEAD=$SELECT(NAR="LAB":"Laboratory",1:"no area")_"_Orderable_Items"
SET B="xmlns:xs="
+23 SET @TMP@(0)=0
+24 SET D=$$BTMP
SET @TMP@(D)=$$XMLHDR^MXMLUTL()
+25 SET D=$$BTMP
SET @TMP@(D)="<"_XHEAD_" "_B_"""http://www.w3.org/2001/XMLSchema"">"
+26 SET D=$$BTMP
SET @TMP@(D)="<Facility>"
+27 SET D=$$BTMP
SET @TMP@(D)="<Facility_Name-Number>"_WB_"</Facility_Name-Number>"
+28 SET A=$$PROD^XUPROD()
SET B=$SELECT(A="1":"YES",1:"NO")
SET D=$$BTMP
SET @TMP@(D)="<Facility_Production_Account>"_B_"</Facility_Production_Account>"
+29 SET A=$GET(^XMB("NETNAME"))
+30 SET LKUP=$SELECT($EXTRACT(HDITYPE,1)="S":"SINGLE",$EXTRACT(HDITYPE,1)="P":"PARTIAL",HDITYPE="ALL":"ALL",1:"")
+31 SET D=$$BTMP
SET @TMP@(D)="<Facility_Net_Name>"_A_"</Facility_Net_Name>"
+32 SET D=$$BTMP
SET @TMP@(D)="<Look_up_Type>"_LKUP_"</Look_up_Type>"
+33 IF LKUP="PARTIAL"
SET D=$$BTMP
SET @TMP@(D)="<Look_up_Partial_Name>"_HDIOIEN_"</Look_up_Partial_Name>"
+34 SET D=$$BTMP
SET @TMP@(D)="</Facility>"
+35 IF LKUP=""
SET D=$$BTMP
SET @TMP@(D)="<Look_up_Type_Error>Look up Type: "_HDIOIEN_", not Identified</Look_up_Type_Error>"
GOTO OUT
+36 ;
+37 ; set up allowable sets by area
+38 FOR I="RX","O RX","UD RX","NV RX","IVA RX","IVB RX","IVM RX","I RX"
SET PHM(I)=1
+39 FOR I="LAB","CH","MI","EM","SP","CY","AU"
SET LAB(I)=1
+40 ;set up if XML
+41 ;
+42 IF HDIOIEN="ALL"
GOTO ALL
+43 IF HDIOIEN?1N.N
SET A=$$GET1^DIQ(101.43,HDIOIEN_",",.01)
IF A'=""
GOTO IEN
+44 ; test names may start with alpha, numeric, punctuation.
+45 GOTO PARTIAL
+46 QUIT
+47 ;
ALL ; get all items for an area
+1 KILL @HDIA1,@HDIA2
+2 DO LIST^DIC(101.43,,"@;.001I","MUQ",,,,,,,HDIA1)
+3 SET A=0
FOR
SET A=$ORDER(@HDIA1@("DILIST",2,A))
if 'A
QUIT
SET B=$GET(@HDIA1@("DILIST",2,A))
SET @HDIA2@(B)=""
+4 KILL @HDIA1
+5 SET HDIOIEN=0
A1 SET HDIOIEN=$ORDER(@HDIA2@(HDIOIEN))
IF 'HDIOIEN
KILL @HDIA2
GOTO OUT
+1 ;check that orderable item is for the area
+2 SET OK=$$CHKO(HDIOIEN)
+3 IF 'OK
GOTO A1
+4 IF NAR="LAB"
DO LAB(HDIOIEN)
+5 GOTO A1
+6 ;
PARTIAL ; get items that partial match the name sent
+1 SET PART=HDIOIEN
KILL ^TMP("HDICHK",$JOB)
+2 KILL @HDIA1,@HDIA2
+3 ; this will pick up those items with mnemonics that are related to the partial name sent in.
+4 ; since a orderable name and its mnemonic can start the same place into a temp area to reduce duplication.
+5 DO LIST^DIC(101.43,,";.01I","",,,PART,"B",,,HDIA1)
+6 ;<
SET A=0
FOR
SET A=$ORDER(@HDIA1@("DILIST",2,A))
if 'A
QUIT
Begin DoDot:1
+7 SET D=$GET(@HDIA1@("DILIST",2,A))
SET E=$GET(@HDIA1@("DILIST",1,A))
SET F=$GET(@HDIA1@("DILIST","ID",A,.01))
+8 SET B=$SELECT(((E'=F)&($EXTRACT(F,1,$LENGTH(PART))'=PART)):1,1:"")
+9 if '$DATA(@HDIA2@(D))
SET @HDIA2@(D)=B
End DoDot:1
+10 KILL @HDIA1
+11 SET A=0
P1A SET A=$ORDER(@HDIA2@(A))
IF 'A
GOTO P2
+1 ; make sure the item is for the correct area.
+2 SET OK=$$CHKO(A)
+3 ;<
IF 'OK
Begin DoDot:1
+4 KILL @HDIA2@(A)
End DoDot:1
+5 GOTO P1A
+6 ;
P2 IF $ORDER(@HDIA2@(0))=""
Begin DoDot:1
+1 SET HDIERAR=HDIERAR_$SELECT(HDIERAR'="":",",1:"")_7
+2 IF $GET(HDIERR)'=""
SET D=$GET(@HDIERR@(0))
SET D=D+1
SET @HDIERR@(0)=D
SET @HDIERR@(D)="Partial_lookup_Error. Partial Name: "_PART_", not found for Area: "_NAR
End DoDot:1
GOTO OUT
+3 SET HDIOIEN=0
P2A SET HDIOIEN=$ORDER(@HDIA2@(HDIOIEN))
IF 'HDIOIEN
KILL @HDIA2
GOTO OUT
+1 SET ORMN=$SELECT($GET(@HDIA2@(HDIOIEN))=1:"YES",1:"")
+2 IF NAR="LAB"
DO LAB(HDIOIEN)
+3 GOTO P2A
+4 ;
IEN ; find entry for a single IEN in 101.43
+1 SET D=$$GET1^DIQ(101.43,HDIOIEN_",",.01)
IF D=""
SET HDIERAR=HDIERAR_$SELECT(HDIERAR'="":",",1:"")_5
Begin DoDot:1
+2 IF $GET(HDIERR)'=""
SET D=$GET(@HDIERR@(0))
SET D=D+1
SET @HDIERR@(0)=D
SET @HDIERR@(D)="Single_Lookup_Error ("_$GET(HDIOIEN)_") Entry Not Found in Orderable Items File"
End DoDot:1
GOTO OUT
+3 ; quit on first good
+4 SET OK=$$CHKO(HDIOIEN)
+5 IF 'OK
SET HDIERAR=HDIERAR_$SELECT(HDIERAR'="":",",1:"")_6
Begin DoDot:1
+6 IF $GET(HDIERR)'=""
SET D=$GET(@HDIERR@(0))
SET D=D+1
SET @HDIERR@(0)=D
SET @HDIERR@(D)="Single_Lookup_Error ("_$GET(HDIOIEN)_") Entry Not Found in Orderable Items File"
End DoDot:1
GOTO OUT
+7 IF $GET(HDIMN)="Y"
SET ORMN="YES"
+8 IF NAR="LAB"
DO LAB(HDIOIEN)
+9 GOTO OUT
+10 ;
OUT ; return to calling routine
+1 SET D=$$BTMP
SET @TMP@(D)="</"_XHEAD_">"
+2 ;<
IF $GET(HDICNT)'=""
Begin DoDot:1
+3 ;<
IF NAR="LAB"
Begin DoDot:2
+4 NEW A,B,C
SET (A,B)=0
FOR
SET A=$ORDER(@TMPCT@("T",A))
if 'A
QUIT
SET B=B+1
+5 SET L=@HDICNT
SET $PIECE(L,U,13)=B
+6 SET (A,B)=0
FOR
SET A=$ORDER(@TMPCT@("M",A))
if 'A
QUIT
SET B=B+1
+7 IF B
SET $PIECE(L,U,14)=B
+8 SET @HDICNT=L
End DoDot:2
End DoDot:1
+9 KILL @HDIRET
+10 MERGE @HDIRET=@TMP
+11 KILL @TMP
+12 KILL A,B,C,D,E,F,G,I,DA,DR,ROOT,TMP,LAB,PHM,NAR,OK,XHEAD,WB,ORMN,PART,LKUP,O,LAM,RAM,PAM
+13 KILL ORDNM,ORIDT,ORIEN,ORST,DIC,DIQ
+14 KILL HDIA1,HDIA2
+15 IF HDIERAR'=""
QUIT HDIERAR
+16 QUIT "0"
+17 QUIT
+18 ;
LAB(LAM) ;get laboratory SDO's
+1 ;
+2 GOTO LEN^HDISDOCL
+3 ;
ORDI(A) ; get info from 101.43
+1 SET DA=A
+2 NEW OA,OB,B,C,D,E,F,O,R,K,M,AAA,AAB,AAC,AAD
+3 SET C=""
SET DIQ="OB"
SET DIQ(0)="IE"
SET DIC=101.43
SET DR=".01;2;.1"
KILL ^UTILITY("DIQ1",$JOB)
DO EN^DIQ1
KILL ^UTILITY("DIQ1",$JOB)
+4 KILL OA
MERGE OA=OB(101.43,DA)
KILL OB
+5 SET ORDNM=$$CHKCHAR($GET(OA(.01,"E")))
SET B=$GET(OA(.1,"I"))
SET ORIEN=DA
SET C=$PIECE($GET(OA(2,"I")),";",1)
+6 SET ORIDT=""
SET ORST=0
if (B&(B<DT+1))
SET ORST=1
if B
SET ORIDT=$$FMTE^XLFDT($PIECE(B,".",1),5)
+7 ;<
IF $GET(HDICNT)'=""
Begin DoDot:1
+8 SET L=@HDICNT
SET K=$PIECE(L,U,2)
SET K=K+1
SET $PIECE(L,U,2)=K
+9 IF ORIDT'=""
SET K=$PIECE(L,U,3)
SET K=K+1
SET $PIECE(L,U,3)=K
+10 IF ORMN'=""
SET K=$PIECE(L,U,4)
SET K=K+1
SET $PIECE(L,U,4)=K
+11 SET @HDICNT=L
End DoDot:1
+12 ; set up order info if XML
+13 SET OIC=OIC+1
+14 SET D=$$BTMP
SET @TMP@(D)="<Orderable_Item>"
+15 SET D=$$BTMP
SET @TMP@(D)="<Orderable_Item_Number>"_ORIEN_"</Orderable_Item_Number>"
+16 SET D=$$BTMP
SET @TMP@(D)="<Orderable_Item_Name>"_ORDNM_"</Orderable_Item_Name>"
+17 SET D=$$BTMP
SET @TMP@(D)="<Orderable_Item_Mnemonic>"_ORMN_"</Orderable_Item_Mnemonic>"
+18 SET D=$$BTMP
SET @TMP@(D)="<Orderable_Item_Inactive_Date>"_ORIDT_"</Orderable_Item_Inactive_Date>"
+19 SET D=$$BTMP
SET @TMP@(D)="<Orderable_Item_Status>"_ORST_"</Orderable_Item_Status>"
+20 ; add in the synonym's
+21 SET D=$$BTMP
SET @TMP@(D)="<Orderable_Item_Synonym>"
+22 KILL AAA
DO LIST^DIC(101.432,","_DA_",","@;.01I","",,,,,,,"AAA")
+23 KILL AAB,AAC,AAD
MERGE AAB=AAA("DILIST","ID"),AAD=AAA("DILIST",2)
+24 SET M=0
FOR
SET M=$ORDER(AAD(M))
if 'M
QUIT
SET F=$GET(AAD(M))
SET AAC(F)=$GET(AAB(M,.01))
+25 ;<
SET O=0
FOR
SET O=$ORDER(AAC(O))
if 'O
QUIT
SET R=$$CHKCHAR($GET(AAC(O)))
Begin DoDot:1
+26 SET D=$$BTMP
SET @TMP@(D)="<Orderable_Item_Synonym_Name>"_R_"</Orderable_Item_Synonym_Name>"
End DoDot:1
+27 SET D=$$BTMP
SET @TMP@(D)="</Orderable_Item_Synonym>"
+28 KILL AAA,AAB,AAC,AAD
+29 QUIT C
+30 ;
+31 ;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 ;
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 SET B=B_C
End DoDot:1
SET L=C
+10 QUIT B
+11 ;
OH10143 ;header 101.43
+1 SET D=$$BTMP
SET @TMP@(D)="<Orderable_Item>"
+2 QUIT
+3 ;
OT10143 ; trailer for 101.43
+1 SET D=$$BTMP
SET @TMP@(D)="</Orderable_Item>"
+2 QUIT
+3 ;
OB10143 ; body for 101.43
+1 SET D=$$BTMP
SET @TMP@(D)="<Orderable_Item_Number>"_ORIEN_"</Orderable_Item_Number>"
+2 SET D=$$BTMP
SET @TMP@(D)="<Orderable_Item_Name>"_ORDNM_"</Orderable_Item_Name>"
+3 SET D=$$BTMP
SET @TMP@(D)="<Orderable_Item_Inactive_Date>"_ORIDT_"</Orderable_Item_Inactive_Date>"
+4 SET D=$$BTMP
SET @TMP@(D)="<Orderable_Item_Status>"_ORST_"</Orderable_Item_Status>"
+5 QUIT
+6 ;
CHKO(HOI) ;check if order belongs to the correct area
+1 NEW A,B,AA,AR,E
+2 SET OK=""
KILL AA
DO LIST^DIC(101.439,","_HOI_",","@;.01I","",,,,,,,"AA")
+3 KILL AR
MERGE AR=AA("DILIST","ID")
KILL AA
+4 SET E=""
FOR
SET E=$ORDER(AR(E))
if 'E
QUIT
SET B=$GET(AR(E,.01))
if $GET(@NAR@(B))=1
SET OK=1
IF (HDIAREA="L"&((B="BB")!(B="HEMA")!(B="AP")!(B="VBC")!(B="VBEC")!(B="Hemo")))
SET OK=""
QUIT
+5 KILL AR,A,B,AA,E
+6 QUIT OK
+7 ;
