Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: HDISDOL

HDISDOL.m

Go to the documentation of this file.
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