TIUHSL ;;SLC/AJB,AGP - Main List Manager for TIUHS ROutines; 10/25/02
;;1.0;TEXT INTEGRATION UTILITIES;**135**;Jun 20, 1997
EN ; -- main entry point for TIUHSLSM
N CENTER,GMTSHDR,GMTSN,POP,VALMBCK,VALMSG,X
D EN^VALM("TIUHSLSM")
Q
;
HDR ; -- header code
N CENTER,HEADER,TITLE,VALMHDR,VALMSG
S TITLE="TIU Health Summary Object."
S CENTER=(IOM-$L(TITLE))/2
S HEADER=$$SETSTR^VALM1(TITLE,"",CENTER,$L(TITLE))
S VALMHDR(1)=HEADER
;display help option
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
D XQORM
Q
;
INIT ; -- init variables and list array
N DIS,IEN,LINE,HSNAME,HSOBIEN,HSTYPE,NAME,NUM,TMP
K TMP($J)
S (LINE,NUM)=0
;
;searches file 8925.1 for hs obj and places into temp array
S IEN="" F S IEN=$O(^TIU(8925.1,"AT","O",IEN)) Q:IEN="" I $G(^TIU(8925.1,IEN,9))["GMTSOBJ" D
.S NAME=$P($G(^TIU(8925.1,IEN,0)),U)
.S HSOBIEN=$P($P($G(^TIU(8925.1,IEN,9)),",",2),")")
.S HSTYPE=$P($G(^GMT(142.5,HSOBIEN,0)),U,3)
.I $G(HSTYPE)'=""&($D(^GMT(142.5,HSOBIEN,0))>0) S HSTYPE=$$GET1^DIQ(142,HSTYPE,.01)
.I $G(HSTYPE)="" S HSTYPE="No Health Summary Type Found"
.S TMP($J,NAME)=IEN_U_HSTYPE
;
;sort temp array in alpha order and display output
S NAME=""
F S NAME=$O(TMP($J,NAME)) Q:NAME="" D
.S IEN=$P(TMP($J,NAME),U)
.S HSNAME=$P(TMP($J,NAME),U,2)
.S LINE=LINE+1
.S NUM=NUM+1
.;
.;set output display
.S DIS=$$SETSTR^VALM1(NUM,"",1,5)
.S DIS=$$SETSTR^VALM1(NAME,DIS,6,37)
.S DIS=$$SETSTR^VALM1(HSNAME,DIS,40,40)
.D SET^VALM10(LINE,DIS,IEN)
S VALMCNT=LINE
K TMP($J)
Q
;
CREATE ;
;call to tiuhsobj
D CLEAN^VALM10
D FULL^VALM1
D CREATE^TIUHSOBJ
D INIT
S VALMBCK="R"
Q
EDIT ;
;lst man function to allow user to select protocal and line item in one command i.e. det=3
;
N HSOBJ,SEL,TRUE,Y
S TRUE=0
S SEL=$P(XQORNOD(0),"=",2)
I $A($E(SEL,$L(SEL)))<48!($A($E(SEL,$L(SEL)))>57) S SEL=$E(SEL,1,$L(SEL)-1)
I SEL["," D Q
.W $C(7),!,"Only one item number allowed." H 2
.S VALMBCK="R"
I SEL="" D
.W !,"Select Entry: (1-"_VALMLST_") " R SEL:DTIME
.I '$T!(SEL=U)!(SEL="") S TRUE=1
I TRUE=1 Q
I 'SEL!(SEL>VALMCNT)!('$D(@VALMAR@("IDX",SEL))) D Q
.W $C(7),!,SEL_" is not a valid item number." H 2
.S VALMBCK="R"
S Y=$O(@VALMAR@("IDX",SEL,""))
D CLEAN^VALM10
D EN^TIUHSV(+Y)
D CLEAN^VALM10
D INIT
Q
;
EDITHSO ;
;lst man function to allow user to select protocal and line item in one command i.e. det=3
;
N HSOBJ,IEN,OBJMETD,SEL,TRUE,Y,YESNO
S TRUE=0
S SEL=$P(XQORNOD(0),"=",2)
I $A($E(SEL,$L(SEL)))<48!($A($E(SEL,$L(SEL)))>57) S SEL=$E(SEL,1,$L(SEL)-1)
I SEL["," D Q
.W $C(7),!,"Only one item number allowed." H 2
.S VALMBCK="R"
I SEL="" D
.W !,"Select Entry: (1-"_VALMLST_") " R SEL:DTIME
.I '$T!(SEL=U)!(SEL="") S TRUE=1
I TRUE=1 Q
I 'SEL!(SEL>VALMCNT)!('$D(@VALMAR@("IDX",SEL))) D Q
.W $C(7),!,SEL_" is not a valid item number." H 2
.S VALMBCK="R"
S Y=$O(@VALMAR@("IDX",SEL,""))
S IEN=+Y
S OBJMETD=^TIU(8925.1,IEN,9)
S HSOBJ=$P($P($G(OBJMETD),",",2),")")
S YESNO="Y"
I $D(^GMT(142.5,HSOBJ,0))=0 D
. W !,"No HS Object found. Create new HS Object now?"
. S DIR(0)="YA0"
. S DIR("B")="NO"
. S DIR("?")="Enter Y or N. For detailed help type ??"
. D ^DIR
. I $D(DIROUT) S DTOUT=1
. I $D(DTOUT)!($D(DUOUT)) S YESNO="N" Q
. S YESNO=$E(Y(0))
. I YESNO="Y" S HSOBJ=$$CRE^GMTSOBJ()
I $G(YESNO)="Y"&(HSOBJ>0) D
. S ^TIU(8925.1,IEN,9)="S X=$$TIU^GMTSOBJ(DFN,"_HSOBJ_")"
. D EN^TIUHSOLM(HSOBJ,IEN)
D CLEAN^VALM10
D INIT
Q
FIND ;
S DIC=8925.1,DIC("A")="Enter OBJECT NAME: "
;
; DIC(0)="ABEOQ" a=ask user for input, b=use b xref only
; e=echo o=only find 1 if exact match
; q=question erroneous input
;
; DIC("S") ensures IEN is greater or equal to 1 and will only
; lookup objects that contain the health summary object routine
;
S DIC(0)="ABEOQ",DIC("S")="I Y'<1,$G(^TIU(8925.1,+Y,9))[""GMTSOBJ"""
W ! D ^DIC I Y=-1 K DIC Q
D EN^TIUHSV(+Y)
K DIC
Q
;
LSEXIT ;
;display help option
N VALMSG
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
D XQORM
Q
;
XQORM ;
S XQORM("#")=$O(^ORD(101,"B","TIUHS EDIT",0))_U_"1:"_VALMCNT
S XQORM("A")="Select Action: "
Q
;
HELP ; -- help code
N X
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
Q
;
EXPND ; -- expand code
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUHSL 4387 printed Dec 13, 2024@02:41:44 Page 2
TIUHSL ;;SLC/AJB,AGP - Main List Manager for TIUHS ROutines; 10/25/02
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**135**;Jun 20, 1997
EN ; -- main entry point for TIUHSLSM
+1 NEW CENTER,GMTSHDR,GMTSN,POP,VALMBCK,VALMSG,X
+2 DO EN^VALM("TIUHSLSM")
+3 QUIT
+4 ;
HDR ; -- header code
+1 NEW CENTER,HEADER,TITLE,VALMHDR,VALMSG
+2 SET TITLE="TIU Health Summary Object."
+3 SET CENTER=(IOM-$LENGTH(TITLE))/2
+4 SET HEADER=$$SETSTR^VALM1(TITLE,"",CENTER,$LENGTH(TITLE))
+5 SET VALMHDR(1)=HEADER
+6 ;display help option
+7 SET VALMSG="+ Next Screen - Prev Screen ?? More Actions"
+8 DO XQORM
+9 QUIT
+10 ;
INIT ; -- init variables and list array
+1 NEW DIS,IEN,LINE,HSNAME,HSOBIEN,HSTYPE,NAME,NUM,TMP
+2 KILL TMP($JOB)
+3 SET (LINE,NUM)=0
+4 ;
+5 ;searches file 8925.1 for hs obj and places into temp array
+6 SET IEN=""
FOR
SET IEN=$ORDER(^TIU(8925.1,"AT","O",IEN))
if IEN=""
QUIT
IF $GET(^TIU(8925.1,IEN,9))["GMTSOBJ"
Begin DoDot:1
+7 SET NAME=$PIECE($GET(^TIU(8925.1,IEN,0)),U)
+8 SET HSOBIEN=$PIECE($PIECE($GET(^TIU(8925.1,IEN,9)),",",2),")")
+9 SET HSTYPE=$PIECE($GET(^GMT(142.5,HSOBIEN,0)),U,3)
+10 IF $GET(HSTYPE)'=""&($DATA(^GMT(142.5,HSOBIEN,0))>0)
SET HSTYPE=$$GET1^DIQ(142,HSTYPE,.01)
+11 IF $GET(HSTYPE)=""
SET HSTYPE="No Health Summary Type Found"
+12 SET TMP($JOB,NAME)=IEN_U_HSTYPE
End DoDot:1
+13 ;
+14 ;sort temp array in alpha order and display output
+15 SET NAME=""
+16 FOR
SET NAME=$ORDER(TMP($JOB,NAME))
if NAME=""
QUIT
Begin DoDot:1
+17 SET IEN=$PIECE(TMP($JOB,NAME),U)
+18 SET HSNAME=$PIECE(TMP($JOB,NAME),U,2)
+19 SET LINE=LINE+1
+20 SET NUM=NUM+1
+21 ;
+22 ;set output display
+23 SET DIS=$$SETSTR^VALM1(NUM,"",1,5)
+24 SET DIS=$$SETSTR^VALM1(NAME,DIS,6,37)
+25 SET DIS=$$SETSTR^VALM1(HSNAME,DIS,40,40)
+26 DO SET^VALM10(LINE,DIS,IEN)
End DoDot:1
+27 SET VALMCNT=LINE
+28 KILL TMP($JOB)
+29 QUIT
+30 ;
CREATE ;
+1 ;call to tiuhsobj
+2 DO CLEAN^VALM10
+3 DO FULL^VALM1
+4 DO CREATE^TIUHSOBJ
+5 DO INIT
+6 SET VALMBCK="R"
+7 QUIT
EDIT ;
+1 ;lst man function to allow user to select protocal and line item in one command i.e. det=3
+2 ;
+3 NEW HSOBJ,SEL,TRUE,Y
+4 SET TRUE=0
+5 SET SEL=$PIECE(XQORNOD(0),"=",2)
+6 IF $ASCII($EXTRACT(SEL,$LENGTH(SEL)))<48!($ASCII($EXTRACT(SEL,$LENGTH(SEL)))>57)
SET SEL=$EXTRACT(SEL,1,$LENGTH(SEL)-1)
+7 IF SEL[","
Begin DoDot:1
+8 WRITE $CHAR(7),!,"Only one item number allowed."
HANG 2
+9 SET VALMBCK="R"
End DoDot:1
QUIT
+10 IF SEL=""
Begin DoDot:1
+11 WRITE !,"Select Entry: (1-"_VALMLST_") "
READ SEL:DTIME
+12 IF '$TEST!(SEL=U)!(SEL="")
SET TRUE=1
End DoDot:1
+13 IF TRUE=1
QUIT
+14 IF 'SEL!(SEL>VALMCNT)!('$DATA(@VALMAR@("IDX",SEL)))
Begin DoDot:1
+15 WRITE $CHAR(7),!,SEL_" is not a valid item number."
HANG 2
+16 SET VALMBCK="R"
End DoDot:1
QUIT
+17 SET Y=$ORDER(@VALMAR@("IDX",SEL,""))
+18 DO CLEAN^VALM10
+19 DO EN^TIUHSV(+Y)
+20 DO CLEAN^VALM10
+21 DO INIT
+22 QUIT
+23 ;
EDITHSO ;
+1 ;lst man function to allow user to select protocal and line item in one command i.e. det=3
+2 ;
+3 NEW HSOBJ,IEN,OBJMETD,SEL,TRUE,Y,YESNO
+4 SET TRUE=0
+5 SET SEL=$PIECE(XQORNOD(0),"=",2)
+6 IF $ASCII($EXTRACT(SEL,$LENGTH(SEL)))<48!($ASCII($EXTRACT(SEL,$LENGTH(SEL)))>57)
SET SEL=$EXTRACT(SEL,1,$LENGTH(SEL)-1)
+7 IF SEL[","
Begin DoDot:1
+8 WRITE $CHAR(7),!,"Only one item number allowed."
HANG 2
+9 SET VALMBCK="R"
End DoDot:1
QUIT
+10 IF SEL=""
Begin DoDot:1
+11 WRITE !,"Select Entry: (1-"_VALMLST_") "
READ SEL:DTIME
+12 IF '$TEST!(SEL=U)!(SEL="")
SET TRUE=1
End DoDot:1
+13 IF TRUE=1
QUIT
+14 IF 'SEL!(SEL>VALMCNT)!('$DATA(@VALMAR@("IDX",SEL)))
Begin DoDot:1
+15 WRITE $CHAR(7),!,SEL_" is not a valid item number."
HANG 2
+16 SET VALMBCK="R"
End DoDot:1
QUIT
+17 SET Y=$ORDER(@VALMAR@("IDX",SEL,""))
+18 SET IEN=+Y
+19 SET OBJMETD=^TIU(8925.1,IEN,9)
+20 SET HSOBJ=$PIECE($PIECE($GET(OBJMETD),",",2),")")
+21 SET YESNO="Y"
+22 IF $DATA(^GMT(142.5,HSOBJ,0))=0
Begin DoDot:1
+23 WRITE !,"No HS Object found. Create new HS Object now?"
+24 SET DIR(0)="YA0"
+25 SET DIR("B")="NO"
+26 SET DIR("?")="Enter Y or N. For detailed help type ??"
+27 DO ^DIR
+28 IF $DATA(DIROUT)
SET DTOUT=1
+29 IF $DATA(DTOUT)!($DATA(DUOUT))
SET YESNO="N"
QUIT
+30 SET YESNO=$EXTRACT(Y(0))
+31 IF YESNO="Y"
SET HSOBJ=$$CRE^GMTSOBJ()
End DoDot:1
+32 IF $GET(YESNO)="Y"&(HSOBJ>0)
Begin DoDot:1
+33 SET ^TIU(8925.1,IEN,9)="S X=$$TIU^GMTSOBJ(DFN,"_HSOBJ_")"
+34 DO EN^TIUHSOLM(HSOBJ,IEN)
End DoDot:1
+35 DO CLEAN^VALM10
+36 DO INIT
+37 QUIT
FIND ;
+1 SET DIC=8925.1
SET DIC("A")="Enter OBJECT NAME: "
+2 ;
+3 ; DIC(0)="ABEOQ" a=ask user for input, b=use b xref only
+4 ; e=echo o=only find 1 if exact match
+5 ; q=question erroneous input
+6 ;
+7 ; DIC("S") ensures IEN is greater or equal to 1 and will only
+8 ; lookup objects that contain the health summary object routine
+9 ;
+10 SET DIC(0)="ABEOQ"
SET DIC("S")="I Y'<1,$G(^TIU(8925.1,+Y,9))[""GMTSOBJ"""
+11 WRITE !
DO ^DIC
IF Y=-1
KILL DIC
QUIT
+12 DO EN^TIUHSV(+Y)
+13 KILL DIC
+14 QUIT
+15 ;
LSEXIT ;
+1 ;display help option
+2 NEW VALMSG
+3 SET VALMSG="+ Next Screen - Prev Screen ?? More Actions"
+4 DO XQORM
+5 QUIT
+6 ;
XQORM ;
+1 SET XQORM("#")=$ORDER(^ORD(101,"B","TIUHS EDIT",0))_U_"1:"_VALMCNT
+2 SET XQORM("A")="Select Action: "
+3 QUIT
+4 ;
HELP ; -- help code
+1 NEW X
+2 SET X="?"
DO DISP^XQORM1
WRITE !!
+3 QUIT
+4 ;
EXIT ; -- exit code
+1 QUIT
+2 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
