- HDISDOL ;BPFO/DTG - LOOK UP SDO CODES FOR ORDERABLE ITEMS; 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)
- ; 6894 - HDI COLLECT SDOS
- ;
- EN ; lookup orderable items for lab
- ; pick area
- N HDIAR,HDAR,PHM,LAB,DIR,RET,DA,DIE,MSG,I,Y,A,B,C,ERR,DIRUT,COUNT,HOK,HDICRT,HDIGO,HDITSK,HDITYPE,HTYP
- N HDIPART,HDISING,HDISP,OIENAM,AA,BB,CC,DD
- S RET="^TMP(""HDISDORET"",$J)",(HDIPART,HDISING,HDISP,OIENAM)="",$P(HDISP," ",75)=""
- D INFO
- AREA ; only for Lab
- S HDIAR="L"
- S HDAR="LAB"
- ; set up allowable sets by area
- F I="LAB","CH","MI","EM","SP","CY","AU" S LAB(I)=1
- ASK ; partial, all, or item
- S HTYP="" K DIR,Y,DIRUT
- S DIR("A")="Enter the Type of Search"
- S DIR(0)="SO^P:PARTIAL;S:SINGLE;A:ALL"
- S DIR("L",1)=" PARTIAL (P)"
- S DIR("L",2)=" SINGLE (S)"
- S DIR("L",3)=" ALL (A)"
- S DIR("?")="Enter the Type of Search for the lookup. P for Partial, S Single, or A for All. Enter '^' to go back"
- D ^DIR
- I $D(DIRUT)!($E(Y)="^")!(Y="") W !,*7,"Type Not Selected." G QUIT
- I "PSA"'[$E($G(Y)) W !,*7,"Invalid Type Entered." G ASK
- S HTYP=$E($G(Y))
- I HTYP="A" G ALL
- I HTYP="P" G PART
- I HTYP="S" G SING
- W !,*7,"Type Not Selected. Quiting" G QUIT
- ;
- ALL ;get all of the orderable items for an area
- K ERR,ZERR,ERRARY
- S ERR="",COUNT="" K @RET
- ;
- W !,*7," Collecting SDO's",!
- S ERR=$$EN^HDISDOC(HDIAR,"ALL","ALL",.RET,"ERRARY","COUNT")
- S OK="" I ERR D I OK G ASK
- . D DISER F I=1:1 S A=$P(ERR,",",I) Q:A="" I A<8!(A=12) S OK=1 Q
- D GOTO
- G AREA
- ;
- SING ; single lookup select
- K DIR,DA,DIRUT
- S ERR="",COUNT="" K @RET,ERRARY
- S DIR(0)="PO^101.43:EMQZ"
- S DIR("A")="Enter the Orderable Item for SDO value"
- S DIR("S")="I $$CHKO^HDISDOL(+Y)"
- D ^DIR
- I $D(DIRUT)!($E(X)="^") G ASK
- I +Y'>0 W *7,!,"Invalid Item" G SING
- S OIEN=+Y
- S SINGM="",A=$P(Y,U,2) I A'=""&($E(A,1,$L(X))'=X) S SINGM="Y"
- ; check if proper group
- S HOK=$$CHKO(OIEN)
- I 'HOK W *7,!,"Orderable Item NOT Associated to Selected Area: LABORATORY" G SING
- S OIENAM=$$GETNAM(OIEN)
- S ERR=$$EN^HDISDOC(HDAR,"S",OIEN,.RET,"ERRARY","COUNT",SINGM)
- S OK="" I ERR D I OK G SING
- . D DISER F I=1:1 S A=$P(ERR,",",I) Q:A="" I A<8!(A=12) S OK=1 Q
- D GOTO
- G SING
- ;
- PART ; enter partial name for lookup
- K DIR,DA,DIRUT
- S ERR="",COUNT="" K @RET,ERRARY
- S DIR("A")="Enter a Case Sensitive Partial Match for an Orderable Item Name"
- S DIR(0)="FO^1:40^"
- S DIR("?")="Enter a case sensitive Partial Match Orderable Item Name to lookup SDO Codes for. Enter '^' to go Back"
- D ^DIR
- I $D(DIRUT)!(Y="^") G ASK
- ; check if any names partial patch and are in the selected area
- S PART=Y
- D LIST^DIC(101.43,,";.01I","",,,PART,"B",,,"AA")
- K AB S A=0 F S A=$O(AA("DILIST",2,A)) Q:'A D ;<
- . S D=$G(AA("DILIST",2,A)),E=$G(AA("DILIST",1,A)),F=$G(AA("DILIST","ID",A,.01))
- . I $E(E,1,$L(PART))=PART S AB(D)=""
- K AA
- S OK="",A=0,A=$O(AB(A)) I 'A G P2
- S A=0 F S A=$O(AB(A)) Q:'A S OK=$$CHKO(A) Q:OK=1 ;<
- K AB
- ;
- P2 I 'OK W *7,!!," None of The Partial Matches Are Associated to The Selected Area: LABORATORY" G PART
- ;
- W !,*7," Collecting SDO's",!
- S HDIPART=Y
- S ERR=$$EN^HDISDOC(HDAR,"P",Y,.RET,"ERRARY","COUNT")
- S OK="" I ERR D I OK G PART
- . D DISER F I=1:1 S A=$P(ERR,",",I) Q:A="" I A<8!(A=12) S OK=1 Q
- D GOTO
- G PART
- ;
- INFO ; Display message, clear screen
- N MSG
- S MSG(1)=" This option allows the user to look up SDO codes for items in the ORDERABLE ITEMS File"
- S MSG(2)=" (#101.43). The lookup is limited to orderable items related to Laboratory"
- s MSG(4)=""
- D CLEAR^VALM1
- D BMES^XPDUTL(.MSG)
- Q
- ;
- INFOQS ; display quick stats for data return
- N MSG,A,B K MSG
- S A="Quick Stat for "_$S(HTYP="P":"Partial Match With",HTYP="A":"All",1:"Single")_" "_$S(HDIAR="L":"Laboratory",1:"Pharmacy")_" Orderable Item"_$S(HTYP="A":"s",HTYP="P":" Name:",1:" Name:")
- S B=$E(HDISP,1,(40-($L(A)\2)))_A
- S MSG(1)=B
- S A="" I HTYP="A" S A="ALL Laboratory Orderable Items"
- I HTYP="P" S A="Partial Name: "_$E(HDIPART,1,63)
- I HTYP="S" S A="IEN: "_OIEN_" Name: "_$E(OIENAM,1,63)
- S B=$E(HDISP,1,(40-($L(A)\2)))_A
- S MSG(2)=B
- G INFOL
- ;
- INFOL ; Display Lab message, clear screen
- S MSG(3)=" Orderable Items File Count: "_$J($P(COUNT,U,2),6)
- S MSG(4)=" Number of Orderable Items File That Are Inactive: "_$J($P(COUNT,U,3),6)
- S MSG(5)=" Number of Orderable Items Partial Match to Mnemonic: "_$J($P(COUNT,U,4),6)
- S MSG(6)=" Number of Primary Lab Tests Count: "_$J($P(COUNT,U,5),6)
- S MSG(7)=" Number of Primary Tests that are Panels: "_$J($P(COUNT,U,6),6)
- S MSG(8)=" Number of Laboratory Tests: "_$J($P(COUNT,U,7),6)
- S MSG(9)=" Number of Unique Laboratory Tests: "_$J($P(COUNT,U,13),6)
- S MSG(10)=" Number of Inactive Laboratory Tests: "_$J($P(COUNT,U,8),6)
- S MSG(11)=" Number of Specimens: "_$J($P(COUNT,U,9),6)
- S MSG(12)=" Number of Inactive Specimens: "_$J($P(COUNT,U,10),6)
- S MSG(13)=" Number of Master Laboratory Tests: "_$J($P(COUNT,U,11),6)
- S MSG(14)=" Number of Unique Master Laboratory Tests: "_$J($P(COUNT,U,14),6)
- S MSG(15)=" Number of Inactive Master Laboratory Tests: "_$J($P(COUNT,U,12),6)
- S MSG(16)=""
- G INFOO
- ;
- INFOO ; output quick stats
- D CLEAR^VALM1
- N A S A=0 F S A=$O(MSG(A)) Q:'A W !,MSG(A)
- N DIR,DIRUT,LREND,LRCNT,LRSUB,LRVAL,LRST,LRSTN,LRTXT,X,Y
- S DIR(0)="FO^0:3",DIR("A")="Press ENTER to Continue",DIR("B")=" "
- D ^DIR
- Q
- ;
- QUIT ; exit here
- K @RET
- K HDIAR,HDAR,PHM,LAB,DIR,RET,DA,DIE,MSG,I,Y,A,B,C,ERR,DIRUT,COUNT
- K HOK,HDICRT,HDIGO,HDITSK,HDITYPE,HTYP
- K HDIPART,HDISING,HDISP,OIENAM
- 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(@HDAR@(B))=1 OK=1 I (HDIAR="L"&((B="BB")!(B="HEMA")!(B="AP")!(B="VBC")!(B="VBEC")!(B="Hemo"))) S OK="" Q
- K AR,A,B,AA,E
- Q OK
- ;
- GETNAM(A) ; get orderable item name if single order
- N C,DIQ,DIC,DR,DA,OB
- S DA=A
- S C="",DIQ="OB",DIQ(0)="IE",DIC=101.43,DR=".01" K ^UTILITY("DIQ1",$J) D EN^DIQ1 K ^UTILITY("DIQ1",$J)
- Q $G(OB(101.43,DA,.01,"E"))
- ;
- GOTO ;
- ; display quick summary
- D INFOQS
- G TYPE
- ; get type
- TYPE ; determine output format
- K DIR,DA,DIRUT
- S DIR("A")="Enter the Output Format"
- S DIR(0)="SO^X:XML;E:EXPORT;R:REPORT"
- S DIR("L",1)=" XML (X)"
- S DIR("L",2)=" EXPORT (E)"
- S DIR("L",3)=" REPORT (R)"
- S DIR("?")="Enter the Output Type for the Search Results. X for XML, E Export Tab Delimited, or R Report. Enter '^' to go back"
- D ^DIR
- I $D(DIRUT)!($E(Y)="^") W !,*7,"Output Type Not Selected" Q
- I ("XER"'[$E($G(Y))) W !,*7,"Valid Type Not Selected. Default to Report" S Y="R"
- S HDITYPE=$E(Y)
- ;
- S HDIGO="^HDISDOL"_HDIAR
- ; move REC to REC1 since most printing will go through taskman
- S A="",HDITSK="" F I=1:1:100 H 1 S A=$R(1000) I $G(^TMP("HDIOUT",A))'=DT S HDITSK=A Q
- S RET1="^TMP(""HDIOUT"",HDITSK)" K @RET1 M @RET1=@RET S @RET1=DT
- ;
- ;device
- DEVICE S %ZIS="Q",%ZIS("A")="Output device: " D ^%ZIS
- I POP D HOME^ZIS W !,*7,"No Device Selected" Q
- S HDICRT=$S($E(IOST,1,2)="C-":1,1:0)
- I (HDICRT&(HTYP="A")&(HDITYPE'="R")) S OK="" D DASK I 'OK G DEVICE
- I $D(IO("Q")) N ZTDTH,ZTRTN,ZTIO,ZTDESC,ZTIO,ZTSAVE D W:$D(ZTSK) !!,"Request queued",!! Q
- . S A=$P($H,",",2)+30,ZTDTH=$P($H,",",1)_","_A,ZTRTN="EN"_HDIGO
- . S ZTDESC="HDI SDO Items For "_HDAR_" Report"
- . K ZTIO
- . F I="HDICRT","HDITSK","HDITYPE","RET1","HDIAR","HDAR","HTYP","COUNT" S ZTSAVE(I)=""
- . D ^%ZTLOAD
- . D ^%ZISC
- I 'HDICRT W !,*7,"....Outputting...",!!
- D @HDIGO
- Q
- ;
- DASK ; double dare for local device if type is ALL
- N DIR,DIRUT,A,B,Y,C
- K DIR,DIRUT
- S DIR(0)="Y",DIR("A")="Are you sure you want ALL of the collected items go to your screen?"
- S DIR("?")="If you enter yes, the ALL output will go to your screen. With XML and EXPORT there is no interupt logic."
- S DIR("B")="No"
- D ^DIR
- I $D(DIRUT) S OK="" Q
- I Y<1 S OK="" Q
- S OK=1
- Q
- ;
- DISER ; display return error type
- I ERR=0 Q
- N MSG,A,I,B S MSG(1)="ERROR ITEMS FROM HDI SDO LOOKUP"
- F I=1:1 S A=$P(ERR,",",I) Q:A="" S B(A)=""
- ; remove multi's of repeating error #'s
- S A=0 F I=1:1 S A=$O(B(A)) Q:'A S MSG(I+1)=A_") "_$P($T(DISTXT+A),";",3)
- I $O(ERRARY(0))>0 D ;<
- . S A=0 F S A=$O(ERRARY(A)) Q:'A S MSG(I+1)=ERRARY(A),I=I+1
- S MSG(I+1)=""
- K A,I
- G INFOO
- ;
- DISTXT ; error text
- ;;Area Not Sent.
- ;;Lookup Value Not Sent.
- ;;Return Value Not Sent.
- ;;Improper Search Area
- ;;Single Item Not Found in ORDERABLE ITEMS File 101.43.
- ;;Single Item Not in Area.
- ;;Partial Lookup Error.
- ;;Orderable Items File Does Not Have Lab Pointer for Item.
- ;;Orderable Item Lab Pointer Not Found in Lab File.
- ;;
- ;;
- ;;Type of Lookup not Sent
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHDISDOL 9050 printed Feb 18, 2025@23:22:52 Page 2
- HDISDOL ;BPFO/DTG - LOOK UP SDO CODES FOR ORDERABLE ITEMS; 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 ; 6894 - HDI COLLECT SDOS
- +6 ;
- EN ; lookup orderable items for lab
- +1 ; pick area
- +2 NEW HDIAR,HDAR,PHM,LAB,DIR,RET,DA,DIE,MSG,I,Y,A,B,C,ERR,DIRUT,COUNT,HOK,HDICRT,HDIGO,HDITSK,HDITYPE,HTYP
- +3 NEW HDIPART,HDISING,HDISP,OIENAM,AA,BB,CC,DD
- +4 SET RET="^TMP(""HDISDORET"",$J)"
- SET (HDIPART,HDISING,HDISP,OIENAM)=""
- SET $PIECE(HDISP," ",75)=""
- +5 DO INFO
- AREA ; only for Lab
- +1 SET HDIAR="L"
- +2 SET HDAR="LAB"
- +3 ; set up allowable sets by area
- +4 FOR I="LAB","CH","MI","EM","SP","CY","AU"
- SET LAB(I)=1
- ASK ; partial, all, or item
- +1 SET HTYP=""
- KILL DIR,Y,DIRUT
- +2 SET DIR("A")="Enter the Type of Search"
- +3 SET DIR(0)="SO^P:PARTIAL;S:SINGLE;A:ALL"
- +4 SET DIR("L",1)=" PARTIAL (P)"
- +5 SET DIR("L",2)=" SINGLE (S)"
- +6 SET DIR("L",3)=" ALL (A)"
- +7 SET DIR("?")="Enter the Type of Search for the lookup. P for Partial, S Single, or A for All. Enter '^' to go back"
- +8 DO ^DIR
- +9 IF $DATA(DIRUT)!($EXTRACT(Y)="^")!(Y="")
- WRITE !,*7,"Type Not Selected."
- GOTO QUIT
- +10 IF "PSA"'[$EXTRACT($GET(Y))
- WRITE !,*7,"Invalid Type Entered."
- GOTO ASK
- +11 SET HTYP=$EXTRACT($GET(Y))
- +12 IF HTYP="A"
- GOTO ALL
- +13 IF HTYP="P"
- GOTO PART
- +14 IF HTYP="S"
- GOTO SING
- +15 WRITE !,*7,"Type Not Selected. Quiting"
- GOTO QUIT
- +16 ;
- ALL ;get all of the orderable items for an area
- +1 KILL ERR,ZERR,ERRARY
- +2 SET ERR=""
- SET COUNT=""
- KILL @RET
- +3 ;
- +4 WRITE !,*7," Collecting SDO's",!
- +5 SET ERR=$$EN^HDISDOC(HDIAR,"ALL","ALL",.RET,"ERRARY","COUNT")
- +6 SET OK=""
- IF ERR
- Begin DoDot:1
- +7 DO DISER
- FOR I=1:1
- SET A=$PIECE(ERR,",",I)
- if A=""
- QUIT
- IF A<8!(A=12)
- SET OK=1
- QUIT
- End DoDot:1
- IF OK
- GOTO ASK
- +8 DO GOTO
- +9 GOTO AREA
- +10 ;
- SING ; single lookup select
- +1 KILL DIR,DA,DIRUT
- +2 SET ERR=""
- SET COUNT=""
- KILL @RET,ERRARY
- +3 SET DIR(0)="PO^101.43:EMQZ"
- +4 SET DIR("A")="Enter the Orderable Item for SDO value"
- +5 SET DIR("S")="I $$CHKO^HDISDOL(+Y)"
- +6 DO ^DIR
- +7 IF $DATA(DIRUT)!($EXTRACT(X)="^")
- GOTO ASK
- +8 IF +Y'>0
- WRITE *7,!,"Invalid Item"
- GOTO SING
- +9 SET OIEN=+Y
- +10 SET SINGM=""
- SET A=$PIECE(Y,U,2)
- IF A'=""&($EXTRACT(A,1,$LENGTH(X))'=X)
- SET SINGM="Y"
- +11 ; check if proper group
- +12 SET HOK=$$CHKO(OIEN)
- +13 IF 'HOK
- WRITE *7,!,"Orderable Item NOT Associated to Selected Area: LABORATORY"
- GOTO SING
- +14 SET OIENAM=$$GETNAM(OIEN)
- +15 SET ERR=$$EN^HDISDOC(HDAR,"S",OIEN,.RET,"ERRARY","COUNT",SINGM)
- +16 SET OK=""
- IF ERR
- Begin DoDot:1
- +17 DO DISER
- FOR I=1:1
- SET A=$PIECE(ERR,",",I)
- if A=""
- QUIT
- IF A<8!(A=12)
- SET OK=1
- QUIT
- End DoDot:1
- IF OK
- GOTO SING
- +18 DO GOTO
- +19 GOTO SING
- +20 ;
- PART ; enter partial name for lookup
- +1 KILL DIR,DA,DIRUT
- +2 SET ERR=""
- SET COUNT=""
- KILL @RET,ERRARY
- +3 SET DIR("A")="Enter a Case Sensitive Partial Match for an Orderable Item Name"
- +4 SET DIR(0)="FO^1:40^"
- +5 SET DIR("?")="Enter a case sensitive Partial Match Orderable Item Name to lookup SDO Codes for. Enter '^' to go Back"
- +6 DO ^DIR
- +7 IF $DATA(DIRUT)!(Y="^")
- GOTO ASK
- +8 ; check if any names partial patch and are in the selected area
- +9 SET PART=Y
- +10 DO LIST^DIC(101.43,,";.01I","",,,PART,"B",,,"AA")
- +11 ;<
- KILL AB
- SET A=0
- FOR
- SET A=$ORDER(AA("DILIST",2,A))
- if 'A
- QUIT
- Begin DoDot:1
- +12 SET D=$GET(AA("DILIST",2,A))
- SET E=$GET(AA("DILIST",1,A))
- SET F=$GET(AA("DILIST","ID",A,.01))
- +13 IF $EXTRACT(E,1,$LENGTH(PART))=PART
- SET AB(D)=""
- End DoDot:1
- +14 KILL AA
- +15 SET OK=""
- SET A=0
- SET A=$ORDER(AB(A))
- IF 'A
- GOTO P2
- +16 ;<
- SET A=0
- FOR
- SET A=$ORDER(AB(A))
- if 'A
- QUIT
- SET OK=$$CHKO(A)
- if OK=1
- QUIT
- +17 KILL AB
- +18 ;
- P2 IF 'OK
- WRITE *7,!!," None of The Partial Matches Are Associated to The Selected Area: LABORATORY"
- GOTO PART
- +1 ;
- +2 WRITE !,*7," Collecting SDO's",!
- +3 SET HDIPART=Y
- +4 SET ERR=$$EN^HDISDOC(HDAR,"P",Y,.RET,"ERRARY","COUNT")
- +5 SET OK=""
- IF ERR
- Begin DoDot:1
- +6 DO DISER
- FOR I=1:1
- SET A=$PIECE(ERR,",",I)
- if A=""
- QUIT
- IF A<8!(A=12)
- SET OK=1
- QUIT
- End DoDot:1
- IF OK
- GOTO PART
- +7 DO GOTO
- +8 GOTO PART
- +9 ;
- INFO ; Display message, clear screen
- +1 NEW MSG
- +2 SET MSG(1)=" This option allows the user to look up SDO codes for items in the ORDERABLE ITEMS File"
- +3 SET MSG(2)=" (#101.43). The lookup is limited to orderable items related to Laboratory"
- +4 SET MSG(4)=""
- +5 DO CLEAR^VALM1
- +6 DO BMES^XPDUTL(.MSG)
- +7 QUIT
- +8 ;
- INFOQS ; display quick stats for data return
- +1 NEW MSG,A,B
- KILL MSG
- +2 SET A="Quick Stat for "_$SELECT(HTYP="P":"Partial Match With",HTYP="A":"All",1:"Single")_" "_$SELECT(HDIAR="L":"Laboratory",1:"Pharmacy")_" Orderable Item"_$SELECT(HTYP="A":"s",HTYP="P":" Name:",1:" Name:")
- +3 SET B=$EXTRACT(HDISP,1,(40-($LENGTH(A)\2)))_A
- +4 SET MSG(1)=B
- +5 SET A=""
- IF HTYP="A"
- SET A="ALL Laboratory Orderable Items"
- +6 IF HTYP="P"
- SET A="Partial Name: "_$EXTRACT(HDIPART,1,63)
- +7 IF HTYP="S"
- SET A="IEN: "_OIEN_" Name: "_$EXTRACT(OIENAM,1,63)
- +8 SET B=$EXTRACT(HDISP,1,(40-($LENGTH(A)\2)))_A
- +9 SET MSG(2)=B
- +10 GOTO INFOL
- +11 ;
- INFOL ; Display Lab message, clear screen
- +1 SET MSG(3)=" Orderable Items File Count: "_$JUSTIFY($PIECE(COUNT,U,2),6)
- +2 SET MSG(4)=" Number of Orderable Items File That Are Inactive: "_$JUSTIFY($PIECE(COUNT,U,3),6)
- +3 SET MSG(5)=" Number of Orderable Items Partial Match to Mnemonic: "_$JUSTIFY($PIECE(COUNT,U,4),6)
- +4 SET MSG(6)=" Number of Primary Lab Tests Count: "_$JUSTIFY($PIECE(COUNT,U,5),6)
- +5 SET MSG(7)=" Number of Primary Tests that are Panels: "_$JUSTIFY($PIECE(COUNT,U,6),6)
- +6 SET MSG(8)=" Number of Laboratory Tests: "_$JUSTIFY($PIECE(COUNT,U,7),6)
- +7 SET MSG(9)=" Number of Unique Laboratory Tests: "_$JUSTIFY($PIECE(COUNT,U,13),6)
- +8 SET MSG(10)=" Number of Inactive Laboratory Tests: "_$JUSTIFY($PIECE(COUNT,U,8),6)
- +9 SET MSG(11)=" Number of Specimens: "_$JUSTIFY($PIECE(COUNT,U,9),6)
- +10 SET MSG(12)=" Number of Inactive Specimens: "_$JUSTIFY($PIECE(COUNT,U,10),6)
- +11 SET MSG(13)=" Number of Master Laboratory Tests: "_$JUSTIFY($PIECE(COUNT,U,11),6)
- +12 SET MSG(14)=" Number of Unique Master Laboratory Tests: "_$JUSTIFY($PIECE(COUNT,U,14),6)
- +13 SET MSG(15)=" Number of Inactive Master Laboratory Tests: "_$JUSTIFY($PIECE(COUNT,U,12),6)
- +14 SET MSG(16)=""
- +15 GOTO INFOO
- +16 ;
- INFOO ; output quick stats
- +1 DO CLEAR^VALM1
- +2 NEW A
- SET A=0
- FOR
- SET A=$ORDER(MSG(A))
- if 'A
- QUIT
- WRITE !,MSG(A)
- +3 NEW DIR,DIRUT,LREND,LRCNT,LRSUB,LRVAL,LRST,LRSTN,LRTXT,X,Y
- +4 SET DIR(0)="FO^0:3"
- SET DIR("A")="Press ENTER to Continue"
- SET DIR("B")=" "
- +5 DO ^DIR
- +6 QUIT
- +7 ;
- QUIT ; exit here
- +1 KILL @RET
- +2 KILL HDIAR,HDAR,PHM,LAB,DIR,RET,DA,DIE,MSG,I,Y,A,B,C,ERR,DIRUT,COUNT
- +3 KILL HOK,HDICRT,HDIGO,HDITSK,HDITYPE,HTYP
- +4 KILL HDIPART,HDISING,HDISP,OIENAM
- +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(@HDAR@(B))=1
- SET OK=1
- IF (HDIAR="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 ;
- GETNAM(A) ; get orderable item name if single order
- +1 NEW C,DIQ,DIC,DR,DA,OB
- +2 SET DA=A
- +3 SET C=""
- SET DIQ="OB"
- SET DIQ(0)="IE"
- SET DIC=101.43
- SET DR=".01"
- KILL ^UTILITY("DIQ1",$JOB)
- DO EN^DIQ1
- KILL ^UTILITY("DIQ1",$JOB)
- +4 QUIT $GET(OB(101.43,DA,.01,"E"))
- +5 ;
- GOTO ;
- +1 ; display quick summary
- +2 DO INFOQS
- +3 GOTO TYPE
- +4 ; get type
- TYPE ; determine output format
- +1 KILL DIR,DA,DIRUT
- +2 SET DIR("A")="Enter the Output Format"
- +3 SET DIR(0)="SO^X:XML;E:EXPORT;R:REPORT"
- +4 SET DIR("L",1)=" XML (X)"
- +5 SET DIR("L",2)=" EXPORT (E)"
- +6 SET DIR("L",3)=" REPORT (R)"
- +7 SET DIR("?")="Enter the Output Type for the Search Results. X for XML, E Export Tab Delimited, or R Report. Enter '^' to go back"
- +8 DO ^DIR
- +9 IF $DATA(DIRUT)!($EXTRACT(Y)="^")
- WRITE !,*7,"Output Type Not Selected"
- QUIT
- +10 IF ("XER"'[$EXTRACT($GET(Y)))
- WRITE !,*7,"Valid Type Not Selected. Default to Report"
- SET Y="R"
- +11 SET HDITYPE=$EXTRACT(Y)
- +12 ;
- +13 SET HDIGO="^HDISDOL"_HDIAR
- +14 ; move REC to REC1 since most printing will go through taskman
- +15 SET A=""
- SET HDITSK=""
- FOR I=1:1:100
- HANG 1
- SET A=$RANDOM(1000)
- IF $GET(^TMP("HDIOUT",A))'=DT
- SET HDITSK=A
- QUIT
- +16 SET RET1="^TMP(""HDIOUT"",HDITSK)"
- KILL @RET1
- MERGE @RET1=@RET
- SET @RET1=DT
- +17 ;
- +18 ;device
- DEVICE SET %ZIS="Q"
- SET %ZIS("A")="Output device: "
- DO ^%ZIS
- +1 IF POP
- DO HOME^ZIS
- WRITE !,*7,"No Device Selected"
- QUIT
- +2 SET HDICRT=$SELECT($EXTRACT(IOST,1,2)="C-":1,1:0)
- +3 IF (HDICRT&(HTYP="A")&(HDITYPE'="R"))
- SET OK=""
- DO DASK
- IF 'OK
- GOTO DEVICE
- +4 IF $DATA(IO("Q"))
- NEW ZTDTH,ZTRTN,ZTIO,ZTDESC,ZTIO,ZTSAVE
- Begin DoDot:1
- +5 SET A=$PIECE($HOROLOG,",",2)+30
- SET ZTDTH=$PIECE($HOROLOG,",",1)_","_A
- SET ZTRTN="EN"_HDIGO
- +6 SET ZTDESC="HDI SDO Items For "_HDAR_" Report"
- +7 KILL ZTIO
- +8 FOR I="HDICRT","HDITSK","HDITYPE","RET1","HDIAR","HDAR","HTYP","COUNT"
- SET ZTSAVE(I)=""
- +9 DO ^%ZTLOAD
- +10 DO ^%ZISC
- End DoDot:1
- if $DATA(ZTSK)
- WRITE !!,"Request queued",!!
- QUIT
- +11 IF 'HDICRT
- WRITE !,*7,"....Outputting...",!!
- +12 DO @HDIGO
- +13 QUIT
- +14 ;
- DASK ; double dare for local device if type is ALL
- +1 NEW DIR,DIRUT,A,B,Y,C
- +2 KILL DIR,DIRUT
- +3 SET DIR(0)="Y"
- SET DIR("A")="Are you sure you want ALL of the collected items go to your screen?"
- +4 SET DIR("?")="If you enter yes, the ALL output will go to your screen. With XML and EXPORT there is no interupt logic."
- +5 SET DIR("B")="No"
- +6 DO ^DIR
- +7 IF $DATA(DIRUT)
- SET OK=""
- QUIT
- +8 IF Y<1
- SET OK=""
- QUIT
- +9 SET OK=1
- +10 QUIT
- +11 ;
- DISER ; display return error type
- +1 IF ERR=0
- QUIT
- +2 NEW MSG,A,I,B
- SET MSG(1)="ERROR ITEMS FROM HDI SDO LOOKUP"
- +3 FOR I=1:1
- SET A=$PIECE(ERR,",",I)
- if A=""
- QUIT
- SET B(A)=""
- +4 ; remove multi's of repeating error #'s
- +5 SET A=0
- FOR I=1:1
- SET A=$ORDER(B(A))
- if 'A
- QUIT
- SET MSG(I+1)=A_") "_$PIECE($TEXT(DISTXT+A),";",3)
- +6 ;<
- IF $ORDER(ERRARY(0))>0
- Begin DoDot:1
- +7 SET A=0
- FOR
- SET A=$ORDER(ERRARY(A))
- if 'A
- QUIT
- SET MSG(I+1)=ERRARY(A)
- SET I=I+1
- End DoDot:1
- +8 SET MSG(I+1)=""
- +9 KILL A,I
- +10 GOTO INFOO
- +11 ;
- DISTXT ; error text
- +1 ;;Area Not Sent.
- +2 ;;Lookup Value Not Sent.
- +3 ;;Return Value Not Sent.
- +4 ;;Improper Search Area
- +5 ;;Single Item Not Found in ORDERABLE ITEMS File 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 ;;Type of Lookup not Sent