TIULA1 ; SLC/JER - More interactive functions ;04-Jun-2012 16:19;DU
;;1.0;TEXT INTEGRATION UTILITIES;**75,113,1009,207,1010**;Jun 20, 1997;Build 24
;IHS/MSC/MGH Changes made to correspond with IHS division setup
TRAVERSE(DA,RETURN,PARM,TYPE) ; Select Document Type(s)
N C,I,XQORM,Y N:'$D(LEVEL) LEVEL S LEVEL=+$G(LEVEL)+1
S:$G(TYPE)']"" TYPE="D"
S XQORM=DA_";TIU(8925.1,",XQORM(0)=$S($L($G(PARM)):PARM,1:"AD")
I XQORM(0)["D" S XQORM("H")="W !!,$$CENTER^TIULS(""--- ""_$P(^TIU(8925.1,+DA,0),U,3)_"" ---""),!"
S XQORM("B")=$G(^DISV(DUZ,"XQORM",DA_";TIU(8925.1,",1))
S XQORM("A")="Select "_$S(XQORM(0)["D":"Document",1:$P(^TIU(8925.1,+DA,0),U,3))_$S("CD"[$P(^TIU(8925.1,+DA,0),U,4):" Component",1:" Type")_$S(+XQORM(0)'=1:"(s)",1:"")_": "
D EN^XQORM
M RETURN(LEVEL)=Y
S I=0 F S I=$O(Y(I)) Q:+I'>0 D
. S J=+$P(Y(I),U,2)
. I $P(^TIU(8925.1,+J,0),U,4)'=TYPE,$D(^TIU(8925.1,+J,10))'<10 D TRAVERSE(+J,.RETURN,$G(PARM))
Q
ASKSIG() ; Prompt for ES, return encrypted data
N ESNAME,ESTITLE,Y S Y=0
D SIG^XUSESIG I X1']"" S:'$D(X) X=0 D BADSIG^TIULG(X) G ASKX
S ESNAME=$P($G(^VA(200,DUZ,20)),U,2),ESTITLE=$P($G(^(20)),U,3)
S Y=1_U_ESNAME_U_ESTITLE
ASKX Q Y
ASKSUBJ() ; Handle query by subject
N Y
S Y=$$READ^TIUU("FO","Where SUBJECT CONTAINS")
Q $$UPPER^TIULS(Y)
ASKLOC() ; Handle query by location
N Y
S Y=$$READ^TIUU("P^44:AEMQ","Select HOSPITAL LOCATION")
Q Y
TYPMATCH(TYPE,CURTYP) ; Check for type match
N TIUI,TIUY S TIUY=0
I $L(TYPE,"!")=1,TYPE=CURTYP S TIUY=1
E F TIUI=1:1:$L(TYPE,"!") I $P(TYPE,"!",TIUI)=CURTYP S TIUY=1 Q
Q TIUY
DOCLIST(CLASS,Y,PARM,DFLT) ; Get preferred documents for user
N TIUDA,XQORM,X
S TIUDA=+$O(^TIU(8925.98,"AC",DUZ,CLASS,0)),XQORM=TIUDA_";TIU(8925.98,"
I +TIUDA'>0!(+$O(^XUTL("XQORM",XQORM,0))'>0) S Y=-1 Q
I $G(DFLT)="LAST" D
. S DFLT=$O(^DISV(DUZ,"XQORM",XQORM,0))
. S DFLT=$S(+DFLT:$G(^DISV(DUZ,"XQORM",XQORM,DFLT)),1:"")
S XQORM(0)=$S(+$P($G(^TIU(8925.98,+TIUDA,10,0)),U,3)=1:"F",1:PARM)
S XQORM("B")=$S(+$P($G(^TIU(8925.98,+TIUDA,10,0)),U,3)=1:$P($G(^(0)),U,3),1:DFLT)
I XQORM(0)'["A" S X=XQORM("B")
S XQORM("A")=$S(CLASS=3:"",1:"Select ")_$S(CLASS=3:"TITLE",1:"Document")_$S(+XQORM(0)'=1:"(s)",1:"")_": "
I XQORM(0)["D" D
. N LISTNAME,PERSNAME S LISTNAME=$$PNAME^TIULC1(CLASS)
. I $E(LISTNAME,$L(LISTNAME))="Y" D
. . S LISTNAME=$E(LISTNAME,1,($L(LISTNAME)-1))_"IES"
. I $E(LISTNAME,$L(LISTNAME))="y" D
. . S LISTNAME=$E(LISTNAME,1,($L(LISTNAME)-1))_"ies"
. S PERSNAME=$$PERSNAME^TIULC1(DUZ)
. S LISTNAME=""""_"--- "_LISTNAME_" for "_PERSNAME_" ---"_""""
. S XQORM("H")="W !!,$$CENTER^TIULS("_LISTNAME_"),!"
S XQORM("S")="I $$CANPICK^TIULP(+$G(^TIU(8925.98,+DA(1),10,+DA,0)))"
D EN^XQORM
Q
SELCAT(Y,PARM,DFLT,TIUOVER) ; Get preferred documents for user
N TIUI,TIUDA,CATREC,CATLOOK,CATSCRN,CATVAL,XQORM,X ;P75 newed CATVAL
N TIUT1,TIUT2,TIUTSTR,TIUHOLD
S TIUI=0
S XQORM="1;TIU(8925.8,"
I $G(DFLT)="LAST" D
. S DFLT=$O(^DISV(DUZ,"XQORM",XQORM,0))
. S DFLT=$S(+DFLT:$G(^DISV(DUZ,"XQORM",XQORM,DFLT)),1:"")
S XQORM(0)=$G(PARM,"1A")
S XQORM("B")=$G(DFLT,"AUTHOR")
I +$G(ORVP) S XQORM("S")="I $G(^XUTL(""XQORM"",XQORM,+$O(^XUTL(""XQORM"",XQORM,""B"",DA,0)),0))'[""Patient"""
I XQORM(0)'["A" S X=XQORM("B")
S XQORM("A")="Select SEARCH CATEGOR"_$S(+XQORM(0)'=1:"IES",1:"Y")_": "
I XQORM(0)["D" S XQORM("H")="W !!,$$CENTER^TIULS(""--- Search Categories ---""),!"
D EN^XQORM
; BEGIN TIU207
; FLAG IF TITLE OR ALL CATEGORIES WERE SELECTED. NEEDED IN HDR^TIURH AS ^TMP("TIUR","TIU OVERRIDE")
S TIUT1="",TIUTSTR=""
F S TIUT1=$O(Y(TIUT1)) Q:TIUT1="" D
.I $P(Y(TIUT1),"^",3)="Title" S TIUTSTR=TIUTSTR_"TITLE"
.I $P(Y(TIUT1),"^",3)="All Categories" S TIUTSTR=TIUTSTR_"ALL"
I TIUTSTR["TITLE" S TIUOVER=TIUTSTR
; IF SPECIFIC CATEGORY AND ALL CATEGORIES WHERE SELECTED THEN REMOVE ALL CATEGORIES.
I $O(Y(""),-1)>1,TIUTSTR["ALL" D
.M TIUHOLD=Y K Y
.S TIUT1="",TIUT2=1
.F S TIUT1=$O(TIUHOLD(TIUT1)) Q:TIUT1="" D
..I $P(TIUHOLD(TIUT1),"^",3)="All Categories" Q
..S Y(TIUT2)=TIUHOLD(TIUT1)
..S Y=TIUT2
..S TIUT2=TIUT2+1
; END TIU207
F S TIUI=$O(Y(TIUI)) Q:+TIUI'>0 D
. S TIUDA=+$P(Y(TIUI),U,2)
. S CATREC=$G(^TIU(8925.8,TIUDA,0))
. S CATSCRN=$G(^TIU(8925.8,TIUDA,1))
. S CATLOOK=$G(^TIU(8925.8,TIUDA,2))
. S CATVAL=-1 ;P75
. I CATLOOK']"",+$P(CATREC,U,4) S CATVAL=$$DICLOOK(CATREC,CATSCRN)
. I CATLOOK]"" S CATVAL=$$LOOK(CATLOOK)
. I +CATVAL'=-1,$L(CATVAL) S Y(TIUI)=$P(CATREC,U,2)_U_CATVAL
. E K Y(TIUI) S Y=+$G(Y)-1
Q
DICLOOK(CATEGORY,SCREEN) ; Call ^DIC to get category value
N DIC,X,Y
S DIC=+$P(CATEGORY,U,4),DIC(0)="AEMQZ"
S DIC("A")="Select "_$P(CATEGORY,U)_": "
I SCREEN]"" X SCREEN
D ^DIC I +$G(DUOUT),(X="^^") S DIROUT=1
Q Y
LOOK(LOOKUP) ; Execute LOOKUP CODE
N X,Y
X LOOKUP
Q Y
GETVSIT(DFN) ; Visit selection code
N X,Y
I +$G(ORVP),'+$G(DFN) S DFN=+$G(ORVP)
D MAIN^TIUVISIT(.Y,$G(DFN))
S Y=$G(Y("VISIT"))
I +Y,+$P(Y,U,2) S $P(Y,U,2)=$$DATE^TIULS($P(Y,U,2),"MM/DD/YY HR:MIN")
Q Y
GETTERM(X) ; Get Lexicon term
N DIC,USEX,Y
S DIC=757.01,DIC(0)="AEMQZ",DIC("A")="Select PROBLEM: "
D ^DIC
I +Y'>0,(X]""),(X'=" "),(X'["^") D
. S USEX=$$READ^TIUU("Y",">>> Use "_X,"Yes")
. I +USEX S Y=1_U_X
Q Y
GETDIV() ; Get Institution Number and Name
N TIUDIV,TIUSTN,Y
;IHS/MSC/MGH Division changes to be in line with IHS
;S TIUDIV=$S($P($G(^DG(43,1,"GL")),U,2):$$MULTDIV,1:$$PRIM^VASITE)
D DIVGET^XUSRB2(.IHSDIV,DUZ)
I IHSDIV(2)>1 S TIUDIV=$$MULTDIV
E S TIUDIV=$$PRIM^VASITE
S TIUSTN=$$SITE^VASITE(,TIUDIV)
; end of IHS mod
S TIUSTN=$$SITE^VASITE(,TIUDIV)
I $P(TIUSTN,U)>0,($P(TIUSTN,U,2)]"") D
. S Y=$P(TIUSTN,U)_U_$P(TIUSTN,U,2)
E D
. S Y=-1
Q Y
MULTDIV() ; User selects from active divisions
N DIR,X,Y
S DIR(0)="PA^40.8:EM"
S DIR("A")="Select DIVISION: "
S DIR("S")="I $$SITE^VASITE(,+Y)>0"
D ^DIR
Q +Y
TIULA1 ; SLC/JER - More interactive functions ;04-Jun-2012 16:19;DU
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**75,113,1009,207,1010**;Jun 20, 1997;Build 24
+2 ;IHS/MSC/MGH Changes made to correspond with IHS division setup
TRAVERSE(DA,RETURN,PARM,TYPE) ; Select Document Type(s)
+1 NEW C,I,XQORM,Y
IF '$DATA(LEVEL)
NEW LEVEL
SET LEVEL=+$GET(LEVEL)+1
+2 IF $GET(TYPE)']""
SET TYPE="D"
+3 SET XQORM=DA_";TIU(8925.1,"
SET XQORM(0)=$SELECT($LENGTH($GET(PARM)):PARM,1:"AD")
+4 IF XQORM(0)["D"
SET XQORM("H")="W !!,$$CENTER^TIULS(""--- ""_$P(^TIU(8925.1,+DA,0),U,3)_"" ---""),!"
+5 SET XQORM("B")=$GET(^DISV(DUZ,"XQORM",DA_";TIU(8925.1,",1))
+6 SET XQORM("A")="Select "_$SELECT(XQORM(0)["D":"Document",1:$PIECE(^TIU(8925.1,+DA,0),U,3))_$SELECT("CD"[$PIECE(^TIU(8925.1,+DA,0),U,4):" Component",1:" Type")_$SELECT(+XQORM(0)'=1:"(s)",1:"")_": "
+7 DO EN^XQORM
+8 MERGE RETURN(LEVEL)=Y
+9 SET I=0
FOR
SET I=$ORDER(Y(I))
IF +I'>0
QUIT
Begin DoDot:1
+10 SET J=+$PIECE(Y(I),U,2)
+11 IF $PIECE(^TIU(8925.1,+J,0),U,4)'=TYPE
IF $DATA(^TIU(8925.1,+J,10))'<10
DO TRAVERSE(+J,.RETURN,$GET(PARM))
End DoDot:1
+12 QUIT
ASKSIG() ; Prompt for ES, return encrypted data
+1 NEW ESNAME,ESTITLE,Y
SET Y=0
+2 DO SIG^XUSESIG
IF X1']""
IF '$DATA(X)
SET X=0
DO BADSIG^TIULG(X)
GOTO ASKX
+3 SET ESNAME=$PIECE($GET(^VA(200,DUZ,20)),U,2)
SET ESTITLE=$PIECE($GET(^(20)),U,3)
+4 SET Y=1_U_ESNAME_U_ESTITLE
ASKX QUIT Y
ASKSUBJ() ; Handle query by subject
+1 NEW Y
+2 SET Y=$$READ^TIUU("FO","Where SUBJECT CONTAINS")
+3 QUIT $$UPPER^TIULS(Y)
ASKLOC() ; Handle query by location
+1 NEW Y
+2 SET Y=$$READ^TIUU("P^44:AEMQ","Select HOSPITAL LOCATION")
+3 QUIT Y
TYPMATCH(TYPE,CURTYP) ; Check for type match
+1 NEW TIUI,TIUY
SET TIUY=0
+2 IF $LENGTH(TYPE,"!")=1
IF TYPE=CURTYP
SET TIUY=1
+3 IF '$TEST
FOR TIUI=1:1:$LENGTH(TYPE,"!")
IF $PIECE(TYPE,"!",TIUI)=CURTYP
SET TIUY=1
QUIT
+4 QUIT TIUY
DOCLIST(CLASS,Y,PARM,DFLT) ; Get preferred documents for user
+1 NEW TIUDA,XQORM,X
+2 SET TIUDA=+$ORDER(^TIU(8925.98,"AC",DUZ,CLASS,0))
SET XQORM=TIUDA_";TIU(8925.98,"
+3 IF +TIUDA'>0!(+$ORDER(^XUTL("XQORM",XQORM,0))'>0)
SET Y=-1
QUIT
+4 IF $GET(DFLT)="LAST"
Begin DoDot:1
+5 SET DFLT=$ORDER(^DISV(DUZ,"XQORM",XQORM,0))
+6 SET DFLT=$SELECT(+DFLT:$GET(^DISV(DUZ,"XQORM",XQORM,DFLT)),1:"")
End DoDot:1
+7 SET XQORM(0)=$SELECT(+$PIECE($GET(^TIU(8925.98,+TIUDA,10,0)),U,3)=1:"F",1:PARM)
+8 SET XQORM("B")=$SELECT(+$PIECE($GET(^TIU(8925.98,+TIUDA,10,0)),U,3)=1:$PIECE($GET(^(0)),U,3),1:DFLT)
+9 IF XQORM(0)'["A"
SET X=XQORM("B")
+10 SET XQORM("A")=$SELECT(CLASS=3:"",1:"Select ")_$SELECT(CLASS=3:"TITLE",1:"Document")_$SELECT(+XQORM(0)'=1:"(s)",1:"")_": "
+11 IF XQORM(0)["D"
Begin DoDot:1
+12 NEW LISTNAME,PERSNAME
SET LISTNAME=$$PNAME^TIULC1(CLASS)
+13 IF $EXTRACT(LISTNAME,$LENGTH(LISTNAME))="Y"
Begin DoDot:2
+14 SET LISTNAME=$EXTRACT(LISTNAME,1,($LENGTH(LISTNAME)-1))_"IES"
End DoDot:2
+15 IF $EXTRACT(LISTNAME,$LENGTH(LISTNAME))="y"
Begin DoDot:2
+16 SET LISTNAME=$EXTRACT(LISTNAME,1,($LENGTH(LISTNAME)-1))_"ies"
End DoDot:2
+17 SET PERSNAME=$$PERSNAME^TIULC1(DUZ)
+18 SET LISTNAME=""""_"--- "_LISTNAME_" for "_PERSNAME_" ---"_""""
+19 SET XQORM("H")="W !!,$$CENTER^TIULS("_LISTNAME_"),!"
End DoDot:1
+20 SET XQORM("S")="I $$CANPICK^TIULP(+$G(^TIU(8925.98,+DA(1),10,+DA,0)))"
+21 DO EN^XQORM
+22 QUIT
SELCAT(Y,PARM,DFLT,TIUOVER) ; Get preferred documents for user
+1 ;P75 newed CATVAL
NEW TIUI,TIUDA,CATREC,CATLOOK,CATSCRN,CATVAL,XQORM,X
+2 NEW TIUT1,TIUT2,TIUTSTR,TIUHOLD
+3 SET TIUI=0
+4 SET XQORM="1;TIU(8925.8,"
+5 IF $GET(DFLT)="LAST"
Begin DoDot:1
+6 SET DFLT=$ORDER(^DISV(DUZ,"XQORM",XQORM,0))
+7 SET DFLT=$SELECT(+DFLT:$GET(^DISV(DUZ,"XQORM",XQORM,DFLT)),1:"")
End DoDot:1
+8 SET XQORM(0)=$GET(PARM,"1A")
+9 SET XQORM("B")=$GET(DFLT,"AUTHOR")
+10 IF +$GET(ORVP)
SET XQORM("S")="I $G(^XUTL(""XQORM"",XQORM,+$O(^XUTL(""XQORM"",XQORM,""B"",DA,0)),0))'[""Patient"""
+11 IF XQORM(0)'["A"
SET X=XQORM("B")
+12 SET XQORM("A")="Select SEARCH CATEGOR"_$SELECT(+XQORM(0)'=1:"IES",1:"Y")_": "
+13 IF XQORM(0)["D"
SET XQORM("H")="W !!,$$CENTER^TIULS(""--- Search Categories ---""),!"
+14 DO EN^XQORM
+15 ; BEGIN TIU207
+16 ; FLAG IF TITLE OR ALL CATEGORIES WERE SELECTED. NEEDED IN HDR^TIURH AS ^TMP("TIUR","TIU OVERRIDE")
+17 SET TIUT1=""
SET TIUTSTR=""
+18 FOR
SET TIUT1=$ORDER(Y(TIUT1))
IF TIUT1=""
QUIT
Begin DoDot:1
+19 IF $PIECE(Y(TIUT1),"^",3)="Title"
SET TIUTSTR=TIUTSTR_"TITLE"
+20 IF $PIECE(Y(TIUT1),"^",3)="All Categories"
SET TIUTSTR=TIUTSTR_"ALL"
End DoDot:1
+21 IF TIUTSTR["TITLE"
SET TIUOVER=TIUTSTR
+22 ; IF SPECIFIC CATEGORY AND ALL CATEGORIES WHERE SELECTED THEN REMOVE ALL CATEGORIES.
+23 IF $ORDER(Y(""),-1)>1
IF TIUTSTR["ALL"
Begin DoDot:1
+24 MERGE TIUHOLD=Y
KILL Y
+25 SET TIUT1=""
SET TIUT2=1
+26 FOR
SET TIUT1=$ORDER(TIUHOLD(TIUT1))
IF TIUT1=""
QUIT
Begin DoDot:2
+27 IF $PIECE(TIUHOLD(TIUT1),"^",3)="All Categories"
QUIT
+28 SET Y(TIUT2)=TIUHOLD(TIUT1)
+29 SET Y=TIUT2
+30 SET TIUT2=TIUT2+1
End DoDot:2
End DoDot:1
+31 ; END TIU207
+32 FOR
SET TIUI=$ORDER(Y(TIUI))
IF +TIUI'>0
QUIT
Begin DoDot:1
+33 SET TIUDA=+$PIECE(Y(TIUI),U,2)
+34 SET CATREC=$GET(^TIU(8925.8,TIUDA,0))
+35 SET CATSCRN=$GET(^TIU(8925.8,TIUDA,1))
+36 SET CATLOOK=$GET(^TIU(8925.8,TIUDA,2))
+37 ;P75
SET CATVAL=-1
+38 IF CATLOOK']""
IF +$PIECE(CATREC,U,4)
SET CATVAL=$$DICLOOK(CATREC,CATSCRN)
+39 IF CATLOOK]""
SET CATVAL=$$LOOK(CATLOOK)
+40 IF +CATVAL'=-1
IF $LENGTH(CATVAL)
SET Y(TIUI)=$PIECE(CATREC,U,2)_U_CATVAL
+41 IF '$TEST
KILL Y(TIUI)
SET Y=+$GET(Y)-1
End DoDot:1
+42 QUIT
DICLOOK(CATEGORY,SCREEN) ; Call ^DIC to get category value
+1 NEW DIC,X,Y
+2 SET DIC=+$PIECE(CATEGORY,U,4)
SET DIC(0)="AEMQZ"
+3 SET DIC("A")="Select "_$PIECE(CATEGORY,U)_": "
+4 IF SCREEN]""
XECUTE SCREEN
+5 DO ^DIC
IF +$GET(DUOUT)
IF (X="^^")
SET DIROUT=1
+6 QUIT Y
LOOK(LOOKUP) ; Execute LOOKUP CODE
+1 NEW X,Y
+2 XECUTE LOOKUP
+3 QUIT Y
GETVSIT(DFN) ; Visit selection code
+1 NEW X,Y
+2 IF +$GET(ORVP)
IF '+$GET(DFN)
SET DFN=+$GET(ORVP)
+3 DO MAIN^TIUVISIT(.Y,$GET(DFN))
+4 SET Y=$GET(Y("VISIT"))
+5 IF +Y
IF +$PIECE(Y,U,2)
SET $PIECE(Y,U,2)=$$DATE^TIULS($PIECE(Y,U,2),"MM/DD/YY HR:MIN")
+6 QUIT Y
GETTERM(X) ; Get Lexicon term
+1 NEW DIC,USEX,Y
+2 SET DIC=757.01
SET DIC(0)="AEMQZ"
SET DIC("A")="Select PROBLEM: "
+3 DO ^DIC
+4 IF +Y'>0
IF (X]"")
IF (X'=" ")
IF (X'["^")
Begin DoDot:1
+5 SET USEX=$$READ^TIUU("Y",">>> Use "_X,"Yes")
+6 IF +USEX
SET Y=1_U_X
End DoDot:1
+7 QUIT Y
GETDIV() ; Get Institution Number and Name
+1 NEW TIUDIV,TIUSTN,Y
+2 ;IHS/MSC/MGH Division changes to be in line with IHS
+3 ;S TIUDIV=$S($P($G(^DG(43,1,"GL")),U,2):$$MULTDIV,1:$$PRIM^VASITE)
+4 DO DIVGET^XUSRB2(.IHSDIV,DUZ)
+5 IF IHSDIV(2)>1
SET TIUDIV=$$MULTDIV
+6 IF '$TEST
SET TIUDIV=$$PRIM^VASITE
+7 SET TIUSTN=$$SITE^VASITE(,TIUDIV)
+8 ; end of IHS mod
+9 SET TIUSTN=$$SITE^VASITE(,TIUDIV)
+10 IF $PIECE(TIUSTN,U)>0
IF ($PIECE(TIUSTN,U,2)]"")
Begin DoDot:1
+11 SET Y=$PIECE(TIUSTN,U)_U_$PIECE(TIUSTN,U,2)
End DoDot:1
+12 IF '$TEST
Begin DoDot:1
+13 SET Y=-1
End DoDot:1
+14 QUIT Y
MULTDIV() ; User selects from active divisions
+1 NEW DIR,X,Y
+2 SET DIR(0)="PA^40.8:EM"
+3 SET DIR("A")="Select DIVISION: "
+4 SET DIR("S")="I $$SITE^VASITE(,+Y)>0"
+5 DO ^DIR
+6 QUIT +Y
