GMTSOBU ; SLC/KER - HS Object - Utility ; 01/06/2003
;;2.7;Health Summary;**58,89**;Oct 20, 1995;Build 61
;
; External References
; DBIA 10096 ^%ZOSF("DEL"
; DBIA 10112 $$SITE^VASITE
; DBIA 10104 $$UP^XLFSTR
; DBIA 10026 ^DIR
;
; Errors
ER1 ; Health Summary Object Exist
N GMTSTXT,GMTSLN S GMTSTXT="Can not install Health Summary Object '"_GMTSOBJ_"'. A Health Summary Object with the same name already exist." D WER S GMTSQIT=1 Q
ER2 ; Health Summary Type Exist
N GMTSTXT,GMTSLN S GMTSTXT="Can not install Health Summary Type '"_GMTSTYP_"' for use by the Health Summary Object '"_GMTSOBJ_"'. A Health Summary Type with the same name already exist." D WER S GMTSQIT=1 Q
ER3 ; Health Summary Title Exist
N GMTSTXT,GMTSLN S GMTSTXT="Can not install Health Summary Type '"_GMTSTYP_"' for use by the Health Summary Object '"_GMTSOBJ_"'. A Health Summary Type with the same TITLE ("_GMTSTTL_") already exist." D WER S GMTSQIT=1 Q
WER ; Write Error
W !," Error:"
WER2 ; Write Error Text
S GMTSLN=$$TRIM($E(GMTSTXT,1,65)),GMTSLN=$$TRIM($P(GMTSLN," ",1,($L(GMTSLN," ")-1))) S:$L(GMTSTXT)<65 GMTSLN=$$TRIM(GMTSTXT) W:$L(GMTSLN) !," ",GMTSLN
S GMTSTXT=$$TRIM($P(GMTSTXT,GMTSLN,2,299)),GMTSLN=$$TRIM($E(GMTSTXT,1,65)),GMTSLN=$$TRIM($P(GMTSLN," ",1,($L(GMTSLN," ")-1))) S:$L(GMTSTXT)<65 GMTSLN=$$TRIM(GMTSTXT) W:$L(GMTSLN) !," ",GMTSLN
S GMTSTXT=$$TRIM($P(GMTSTXT,GMTSLN,2,299)),GMTSLN=$$TRIM($E(GMTSTXT,1,65)),GMTSLN=$$TRIM($P(GMTSLN," ",1,($L(GMTSLN," ")-1))) S:$L(GMTSTXT)<65 GMTSLN=$$TRIM(GMTSTXT) W:$L(GMTSLN) !," ",GMTSLN
Q
;
EHST(X) ; Existing Health Summary Type
N GMTSRTN,GMTSEDAT,GMTSOBJ,GMTSTYP,GMTSTXT,GMTSLN,GMTS
N Y,DIR,DIROUT,DTOUT,DUOUT
S GMTSRTN="GMTSOBX",GMTSOBJ=$P($$TX(GMTSRTN,"OBJ",1),";",2),GMTSTYP=$P($$TX(GMTSRTN,"TYPE",1),";",2)
Q:'$L(GMTSOBJ)!('$L(GMTSTYP)) 0
W ! S GMTSTXT="Can not install Health Summary Type '"_GMTSTYP_"' to be used"
S GMTSTXT=GMTSTXT_" by the object. A Health Summary Type with the same name already exist." D WER2
S GMTSEDAT=$$NWX(GMTSTYP) Q:+($G(GMTSEDAT))'>0 0
S GMTSTXT="Do you want to use the pre-existing Health Summary Type '"_GMTSTYP_"' for this Object? (Y/N)"
S GMTSLN=$$TRIM($E(GMTSTXT,1,65))
S GMTSLN=$$TRIM($P(GMTSLN," ",1,($L(GMTSLN," ")-1)))
S:$L(GMTSTXT)<65 GMTSLN=$$TRIM(GMTSTXT) S:$L(GMTSLN) DIR("A",1)=" "_GMTSLN_" "
S GMTSTXT=$$TRIM($P(GMTSTXT,GMTSLN,2,299))
S GMTSLN=$$TRIM($E(GMTSTXT,1,65))
S GMTSLN=$$TRIM($P(GMTSLN," ",1,($L(GMTSLN," ")-1)))
S:$L(GMTSTXT)<65 GMTSLN=$$TRIM(GMTSTXT) S:$L(GMTSLN) DIR("A")=" "_GMTSLN_" "
S DIR("B")="N",DIR(0)="YAO",(DIR("?"),DIR("??"))="^D YNH^GMTSOBU" W ! D ^DIR
S GMTS=+($G(Y)) S X=0,GMTSQIT=1
; Don't use the pre-existing HS
I +GMTS'>0 S GMTSQIT=1,GMTSEDAT=0 D Q X
. ; Rename HS
. D REN I $L($G(GMTSETYP)),$L($G(GMTSETTL)) S GMTSTYP=GMTSETYP,GMTSTTL=GMTSETTL,(GMTSEDAT,GMTSDAT)=$$TIEN
. S X=+GMTSEDAT S:+X>0 GMTSQIT=0
; Use the pre-existing HS
;AGP CHANGE TO TEST POSSIBLE FIX
;I +GMTS>0,$L(GMTSTYP) BREAK S GMTSTE=1,(X,GMTSEDAT)=+($G(GMTSDAT)),GMTSQIT=0
I +GMTS>0,$L(GMTSTYP) S GMTSTE=1,(X,GMTSEDAT)=+($G(GMTSEDAT)),GMTSQIT=0
Q X
REN ; Rename Health Summary Type
N DIR,DIROUT,DUOUT,DTOUT,X,Y,GMTSNN,GMTSNT,GMTSNA S (GMTSETYP,GMTSETTL)=""
S DIR("A")=" Do you want to rename the imported Health Summary Type? (Y/N) "
S DIR("B")="Y",DIR(0)="YAO"
S (DIR("?"),DIR("??"))="^D YNH^GMTSOBU"
W ! D ^DIR Q:+Y=0
S GMTSETYP=$$EDN($G(GMTSTYP)) Q:'$L($G(GMTSETYP))
S GMTSETTL=$$EDT($G(GMTSTTL),$G(GMTSETYP)) S:'$L($G(GMTSETTL)) GMTSETYP=""
Q
EDN(X) ; Edit Health Summary Type Name
N DIR,DIROUT,DUOUT,DTOUT,Y,GMTSNN,GMTSON,GMTSNA,GMTSETYP
S GMTSON=$G(X),GMTSETYP="" Q:'$L(GMTSON) ""
S DIR("A")=" Re-Name '"_GMTSON_"' to: "
S GMTSNN=GMTSON F S GMTSNN=$$TRIM($$NN(GMTSNN)) Q:+($$NWX(GMTSNN))=0
S:$L(GMTSNN) DIR("B")=GMTSNN
S DIR(0)="FAO^3:30^N GMTS S GMTS=$$CKN^GMTSOBU($G(X)) W:+GMTS=0&($L(X)) !!,"" '""_$G(X)_""' already exist."" K:+GMTS=0&($L(X)) X"
S (DIR("?"),DIR("??"))="^D LNH^GMTSOBU"
D ^DIR S X="" S:$L(Y)>2&($L(Y)<31) X=Y
Q X
EDT(X,Y) ; Edit Health Summary Type Title
N DIR,DIROUT,DUOUT,DTOUT,GMTSNT,GMTSOT,GMTSTT,GMTSTY,GMTSNA,GMTSETYP
S GMTSOT=$G(X),GMTSTT=$$EN2^GMTSUMX($G(Y)),GMTSTY=$G(Y)
S GMTSNT=GMTSOT S:'$L(GMTSNT) GMTSNT=GMTSTT S GMTSNT=$$EN2^GMTSUMX(GMTSNT)
F S GMTSNT=$$TRIM($$NN(GMTSNT)) Q:+($$TWX(GMTSNT))=0
S DIR("A")=" Title: " S:$L(GMTSNT)>2&($L(GMTSNT)<31) DIR("B")=GMTSNT
S DIR(0)="FAO^3:30^N GMTS S GMTS=$$CKT^GMTSOBU($G(X)) W:+GMTS=0&($L(X)) !!,"" '""_$G(X)_""' already exist."" K:+GMTS=0&($L(X)) X"
S (DIR("?"),DIR("??"))="^D LNH^GMTSOBU"
D ^DIR S X="" S:$L(Y)>2&($L(Y)<31) X=Y
Q X
YNH ; Yes No Help
W !," Enter either 'Y' or 'N'." Q
LNH ; Length Help
W !," This response must have at least 3 characters and no more than 30"
W !," characters and must not contain embedded uparrow." Q
CKN(X) ; Check New Name is Unique
S X=$$NWX($G(X)) S X=$S(+X>0:0,1:1) Q X
CKT(X) ; Check New Title is Unique
S X=$$TWX($G(X)) S X=$S(+X>0:0,1:1) Q X
;
; Miscellaneous
TIEN(X) ; Type IEN
N GMTSI,GMTSIEN S GMTSIEN=0 F GMTSI=5:1 D Q:+GMTSIEN>0
. Q:$G(^GMT(142,GMTSI,0))["GMTS HS ADHOC OPTION" I GMTSI>4999999 S GMTSI=5999999 Q
. S:'$D(^GMT(142,GMTSI)) GMTSIEN=GMTSI
S X=GMTSIEN Q X
OIEN(X) ; Object IEN
N GMTSIEN,GMTSIT S GMTSIT=+($P($$SITE^VASITE,"^",3)) Q:+GMTSIT=0 -1
S GMTSIEN=+($O(^GMT(142.5,(GMTSIT_"9999")),-1))+1 Q:$D(^GMT(142.5,+GMTSIEN,0)) -1
S X=GMTSIEN
Q X
BOX(X) ; Get HS Object IEN from B Index
N GMTSI,GMTSX,GMTSO,GMTSN S GMTSN=$G(X) Q:'$L(GMTSN) 0
S (GMTSI,GMTSO)=0 F S GMTSI=$O(^GMT(142.5,"B",$E(GMTSN,1,30),GMTSI)) Q:+GMTSI=0 D Q:GMTSO>0
. S GMTSX=$P($G(^GMT(142.5,+GMTSI,0)),"^",1) S:$$UP^XLFSTR(GMTSN)=$$UP^XLFSTR(GMTSX) GMTSO=GMTSI
S X=+($G(GMTSO))
Q X
NWX(X) ; Get HS Name IEN from Word Index
N GMTSI,GMTSX,GMTST,GMTSN,GMTSW S GMTSN=$$UP^XLFSTR($G(X)) Q:'$L(GMTSN) 0
S GMTSW=$P(GMTSN," ",1),(GMTSI,GMTST)=0 F S GMTSI=$O(^GMT(142,"AW",GMTSW,GMTSI)) Q:+GMTSI=0 D Q:GMTST>0
. S GMTSX=$P($G(^GMT(142,+GMTSI,0)),"^",1) S:$$UP^XLFSTR(GMTSN)=$$UP^XLFSTR(GMTSX) GMTST=GMTSI
S X=+($G(GMTST))
Q X
TWX(X) ; Get HS Title IEN from Word Index
N GMTSI,GMTSX,GMTST,GMTSN,GMTSW S GMTSN=$$UP^XLFSTR($G(X)) Q:'$L(GMTSN) 0
S GMTSW=$P(GMTSN," ",1),(GMTSI,GMTST)=0 F S GMTSI=$O(^GMT(142,"AW",GMTSW,GMTSI)) Q:+GMTSI=0 D Q:GMTST>0
. S GMTSX=$P($G(^GMT(142,+GMTSI,"T")),"^",1) S:$$UP^XLFSTR(GMTSN)=$$UP^XLFSTR(GMTSX) GMTST=GMTSI
S X=+($G(GMTST))
Q X
NN(X) ; New Name
N GMTSNN,GMTSNI,GMTSNS
S GMTSNN=$G(X),GMTSNI=$P(GMTSNN," ",$L(GMTSNN," "))
S GMTSNS=$P(GMTSNN," ",1,($L(GMTSNN," ")-1))
S:+GMTSNI=0 GMTSNS=GMTSNN S:+GMTSNI=0 GMTSNI=1 S GMTSNI=+GMTSNI+1
S GMTSNS=$$TRIM(GMTSNS)
S:($L(GMTSNS)+$L(GMTSNI))>29 GMTSNS=$E(GMTSNS,1,30-($L(GMTSNI)+2))
S X=$$TRIM(GMTSNS)_" "_GMTSNI
Q X
DEL(X) ; Delete Routine X
S X=$G(X) Q:'$L(X) Q:$L(X)>8 Q:$$ROK(X)=0 X ^%ZOSF("DEL") Q
ROK(X) ; Routine Ok
S X=$G(X) Q:'$L(X) 0
N GMTSEX,GMTSTXT S GMTSEX="S GMTSTXT=$T(+1^"_X_")" X GMTSEX Q:'$L(GMTSTXT) 0 Q 1
TX(R,T,L) ; Get Text (Routine/Tag/Line)
N GMTSEX,GMTSTXT S GMTSEX="S GMTSTXT=$T("_T_"+"_L_"^"_R_")" X GMTSEX S X=GMTSTXT
Q X
TRIM(X) ; Trim Spaces
S X=$G(X) F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
S X=$$UP^XLFSTR($E(X,1))_$E(X,2,$L(X))
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSOBU 7543 printed Sep 23, 2025@19:34:32 Page 2
GMTSOBU ; SLC/KER - HS Object - Utility ; 01/06/2003
+1 ;;2.7;Health Summary;**58,89**;Oct 20, 1995;Build 61
+2 ;
+3 ; External References
+4 ; DBIA 10096 ^%ZOSF("DEL"
+5 ; DBIA 10112 $$SITE^VASITE
+6 ; DBIA 10104 $$UP^XLFSTR
+7 ; DBIA 10026 ^DIR
+8 ;
+9 ; Errors
ER1 ; Health Summary Object Exist
+1 NEW GMTSTXT,GMTSLN
SET GMTSTXT="Can not install Health Summary Object '"_GMTSOBJ_"'. A Health Summary Object with the same name already exist."
DO WER
SET GMTSQIT=1
QUIT
ER2 ; Health Summary Type Exist
+1 NEW GMTSTXT,GMTSLN
SET GMTSTXT="Can not install Health Summary Type '"_GMTSTYP_"' for use by the Health Summary Object '"_GMTSOBJ_"'. A Health Summary Type with the same name already exist."
DO WER
SET GMTSQIT=1
QUIT
ER3 ; Health Summary Title Exist
+1 NEW GMTSTXT,GMTSLN
SET GMTSTXT="Can not install Health Summary Type '"_GMTSTYP_"' for use by the Health Summary Object '"_GMTSOBJ_"'. A Health Summary Type with the same TITLE ("_GMTSTTL_") already exist."
DO WER
SET GMTSQIT=1
QUIT
WER ; Write Error
+1 WRITE !," Error:"
WER2 ; Write Error Text
+1 SET GMTSLN=$$TRIM($EXTRACT(GMTSTXT,1,65))
SET GMTSLN=$$TRIM($PIECE(GMTSLN," ",1,($LENGTH(GMTSLN," ")-1)))
if $LENGTH(GMTSTXT)<65
SET GMTSLN=$$TRIM(GMTSTXT)
if $LENGTH(GMTSLN)
WRITE !," ",GMTSLN
+2 SET GMTSTXT=$$TRIM($PIECE(GMTSTXT,GMTSLN,2,299))
SET GMTSLN=$$TRIM($EXTRACT(GMTSTXT,1,65))
SET GMTSLN=$$TRIM($PIECE(GMTSLN," ",1,($LENGTH(GMTSLN," ")-1)))
if $LENGTH(GMTSTXT)<65
SET GMTSLN=$$TRIM(GMTSTXT)
if $LENGTH(GMTSLN)
WRITE !," ",GMTSLN
+3 SET GMTSTXT=$$TRIM($PIECE(GMTSTXT,GMTSLN,2,299))
SET GMTSLN=$$TRIM($EXTRACT(GMTSTXT,1,65))
SET GMTSLN=$$TRIM($PIECE(GMTSLN," ",1,($LENGTH(GMTSLN," ")-1)))
if $LENGTH(GMTSTXT)<65
SET GMTSLN=$$TRIM(GMTSTXT)
if $LENGTH(GMTSLN)
WRITE !," ",GMTSLN
+4 QUIT
+5 ;
EHST(X) ; Existing Health Summary Type
+1 NEW GMTSRTN,GMTSEDAT,GMTSOBJ,GMTSTYP,GMTSTXT,GMTSLN,GMTS
+2 NEW Y,DIR,DIROUT,DTOUT,DUOUT
+3 SET GMTSRTN="GMTSOBX"
SET GMTSOBJ=$PIECE($$TX(GMTSRTN,"OBJ",1),";",2)
SET GMTSTYP=$PIECE($$TX(GMTSRTN,"TYPE",1),";",2)
+4 if '$LENGTH(GMTSOBJ)!('$LENGTH(GMTSTYP))
QUIT 0
+5 WRITE !
SET GMTSTXT="Can not install Health Summary Type '"_GMTSTYP_"' to be used"
+6 SET GMTSTXT=GMTSTXT_" by the object. A Health Summary Type with the same name already exist."
DO WER2
+7 SET GMTSEDAT=$$NWX(GMTSTYP)
if +($GET(GMTSEDAT))'>0
QUIT 0
+8 SET GMTSTXT="Do you want to use the pre-existing Health Summary Type '"_GMTSTYP_"' for this Object? (Y/N)"
+9 SET GMTSLN=$$TRIM($EXTRACT(GMTSTXT,1,65))
+10 SET GMTSLN=$$TRIM($PIECE(GMTSLN," ",1,($LENGTH(GMTSLN," ")-1)))
+11 if $LENGTH(GMTSTXT)<65
SET GMTSLN=$$TRIM(GMTSTXT)
if $LENGTH(GMTSLN)
SET DIR("A",1)=" "_GMTSLN_" "
+12 SET GMTSTXT=$$TRIM($PIECE(GMTSTXT,GMTSLN,2,299))
+13 SET GMTSLN=$$TRIM($EXTRACT(GMTSTXT,1,65))
+14 SET GMTSLN=$$TRIM($PIECE(GMTSLN," ",1,($LENGTH(GMTSLN," ")-1)))
+15 if $LENGTH(GMTSTXT)<65
SET GMTSLN=$$TRIM(GMTSTXT)
if $LENGTH(GMTSLN)
SET DIR("A")=" "_GMTSLN_" "
+16 SET DIR("B")="N"
SET DIR(0)="YAO"
SET (DIR("?"),DIR("??"))="^D YNH^GMTSOBU"
WRITE !
DO ^DIR
+17 SET GMTS=+($GET(Y))
SET X=0
SET GMTSQIT=1
+18 ; Don't use the pre-existing HS
+19 IF +GMTS'>0
SET GMTSQIT=1
SET GMTSEDAT=0
Begin DoDot:1
+20 ; Rename HS
+21 DO REN
IF $LENGTH($GET(GMTSETYP))
IF $LENGTH($GET(GMTSETTL))
SET GMTSTYP=GMTSETYP
SET GMTSTTL=GMTSETTL
SET (GMTSEDAT,GMTSDAT)=$$TIEN
+22 SET X=+GMTSEDAT
if +X>0
SET GMTSQIT=0
End DoDot:1
QUIT X
+23 ; Use the pre-existing HS
+24 ;AGP CHANGE TO TEST POSSIBLE FIX
+25 ;I +GMTS>0,$L(GMTSTYP) BREAK S GMTSTE=1,(X,GMTSEDAT)=+($G(GMTSDAT)),GMTSQIT=0
+26 IF +GMTS>0
IF $LENGTH(GMTSTYP)
SET GMTSTE=1
SET (X,GMTSEDAT)=+($GET(GMTSEDAT))
SET GMTSQIT=0
+27 QUIT X
REN ; Rename Health Summary Type
+1 NEW DIR,DIROUT,DUOUT,DTOUT,X,Y,GMTSNN,GMTSNT,GMTSNA
SET (GMTSETYP,GMTSETTL)=""
+2 SET DIR("A")=" Do you want to rename the imported Health Summary Type? (Y/N) "
+3 SET DIR("B")="Y"
SET DIR(0)="YAO"
+4 SET (DIR("?"),DIR("??"))="^D YNH^GMTSOBU"
+5 WRITE !
DO ^DIR
if +Y=0
QUIT
+6 SET GMTSETYP=$$EDN($GET(GMTSTYP))
if '$LENGTH($GET(GMTSETYP))
QUIT
+7 SET GMTSETTL=$$EDT($GET(GMTSTTL),$GET(GMTSETYP))
if '$LENGTH($GET(GMTSETTL))
SET GMTSETYP=""
+8 QUIT
EDN(X) ; Edit Health Summary Type Name
+1 NEW DIR,DIROUT,DUOUT,DTOUT,Y,GMTSNN,GMTSON,GMTSNA,GMTSETYP
+2 SET GMTSON=$GET(X)
SET GMTSETYP=""
if '$LENGTH(GMTSON)
QUIT ""
+3 SET DIR("A")=" Re-Name '"_GMTSON_"' to: "
+4 SET GMTSNN=GMTSON
FOR
SET GMTSNN=$$TRIM($$NN(GMTSNN))
if +($$NWX(GMTSNN))=0
QUIT
+5 if $LENGTH(GMTSNN)
SET DIR("B")=GMTSNN
+6 SET DIR(0)="FAO^3:30^N GMTS S GMTS=$$CKN^GMTSOBU($G(X)) W:+GMTS=0&($L(X)) !!,"" '""_$G(X)_""' already exist."" K:+GMTS=0&($L(X)) X"
+7 SET (DIR("?"),DIR("??"))="^D LNH^GMTSOBU"
+8 DO ^DIR
SET X=""
if $LENGTH(Y)>2&($LENGTH(Y)<31)
SET X=Y
+9 QUIT X
EDT(X,Y) ; Edit Health Summary Type Title
+1 NEW DIR,DIROUT,DUOUT,DTOUT,GMTSNT,GMTSOT,GMTSTT,GMTSTY,GMTSNA,GMTSETYP
+2 SET GMTSOT=$GET(X)
SET GMTSTT=$$EN2^GMTSUMX($GET(Y))
SET GMTSTY=$GET(Y)
+3 SET GMTSNT=GMTSOT
if '$LENGTH(GMTSNT)
SET GMTSNT=GMTSTT
SET GMTSNT=$$EN2^GMTSUMX(GMTSNT)
+4 FOR
SET GMTSNT=$$TRIM($$NN(GMTSNT))
if +($$TWX(GMTSNT))=0
QUIT
+5 SET DIR("A")=" Title: "
if $LENGTH(GMTSNT)>2&($LENGTH(GMTSNT)<31)
SET DIR("B")=GMTSNT
+6 SET DIR(0)="FAO^3:30^N GMTS S GMTS=$$CKT^GMTSOBU($G(X)) W:+GMTS=0&($L(X)) !!,"" '""_$G(X)_""' already exist."" K:+GMTS=0&($L(X)) X"
+7 SET (DIR("?"),DIR("??"))="^D LNH^GMTSOBU"
+8 DO ^DIR
SET X=""
if $LENGTH(Y)>2&($LENGTH(Y)<31)
SET X=Y
+9 QUIT X
YNH ; Yes No Help
+1 WRITE !," Enter either 'Y' or 'N'."
QUIT
LNH ; Length Help
+1 WRITE !," This response must have at least 3 characters and no more than 30"
+2 WRITE !," characters and must not contain embedded uparrow."
QUIT
CKN(X) ; Check New Name is Unique
+1 SET X=$$NWX($GET(X))
SET X=$SELECT(+X>0:0,1:1)
QUIT X
CKT(X) ; Check New Title is Unique
+1 SET X=$$TWX($GET(X))
SET X=$SELECT(+X>0:0,1:1)
QUIT X
+2 ;
+3 ; Miscellaneous
TIEN(X) ; Type IEN
+1 NEW GMTSI,GMTSIEN
SET GMTSIEN=0
FOR GMTSI=5:1
Begin DoDot:1
+2 if $GET(^GMT(142,GMTSI,0))["GMTS HS ADHOC OPTION"
QUIT
IF GMTSI>4999999
SET GMTSI=5999999
QUIT
+3 if '$DATA(^GMT(142,GMTSI))
SET GMTSIEN=GMTSI
End DoDot:1
if +GMTSIEN>0
QUIT
+4 SET X=GMTSIEN
QUIT X
OIEN(X) ; Object IEN
+1 NEW GMTSIEN,GMTSIT
SET GMTSIT=+($PIECE($$SITE^VASITE,"^",3))
if +GMTSIT=0
QUIT -1
+2 SET GMTSIEN=+($ORDER(^GMT(142.5,(GMTSIT_"9999")),-1))+1
if $DATA(^GMT(142.5,+GMTSIEN,0))
QUIT -1
+3 SET X=GMTSIEN
+4 QUIT X
BOX(X) ; Get HS Object IEN from B Index
+1 NEW GMTSI,GMTSX,GMTSO,GMTSN
SET GMTSN=$GET(X)
if '$LENGTH(GMTSN)
QUIT 0
+2 SET (GMTSI,GMTSO)=0
FOR
SET GMTSI=$ORDER(^GMT(142.5,"B",$EXTRACT(GMTSN,1,30),GMTSI))
if +GMTSI=0
QUIT
Begin DoDot:1
+3 SET GMTSX=$PIECE($GET(^GMT(142.5,+GMTSI,0)),"^",1)
if $$UP^XLFSTR(GMTSN)=$$UP^XLFSTR(GMTSX)
SET GMTSO=GMTSI
End DoDot:1
if GMTSO>0
QUIT
+4 SET X=+($GET(GMTSO))
+5 QUIT X
NWX(X) ; Get HS Name IEN from Word Index
+1 NEW GMTSI,GMTSX,GMTST,GMTSN,GMTSW
SET GMTSN=$$UP^XLFSTR($GET(X))
if '$LENGTH(GMTSN)
QUIT 0
+2 SET GMTSW=$PIECE(GMTSN," ",1)
SET (GMTSI,GMTST)=0
FOR
SET GMTSI=$ORDER(^GMT(142,"AW",GMTSW,GMTSI))
if +GMTSI=0
QUIT
Begin DoDot:1
+3 SET GMTSX=$PIECE($GET(^GMT(142,+GMTSI,0)),"^",1)
if $$UP^XLFSTR(GMTSN)=$$UP^XLFSTR(GMTSX)
SET GMTST=GMTSI
End DoDot:1
if GMTST>0
QUIT
+4 SET X=+($GET(GMTST))
+5 QUIT X
TWX(X) ; Get HS Title IEN from Word Index
+1 NEW GMTSI,GMTSX,GMTST,GMTSN,GMTSW
SET GMTSN=$$UP^XLFSTR($GET(X))
if '$LENGTH(GMTSN)
QUIT 0
+2 SET GMTSW=$PIECE(GMTSN," ",1)
SET (GMTSI,GMTST)=0
FOR
SET GMTSI=$ORDER(^GMT(142,"AW",GMTSW,GMTSI))
if +GMTSI=0
QUIT
Begin DoDot:1
+3 SET GMTSX=$PIECE($GET(^GMT(142,+GMTSI,"T")),"^",1)
if $$UP^XLFSTR(GMTSN)=$$UP^XLFSTR(GMTSX)
SET GMTST=GMTSI
End DoDot:1
if GMTST>0
QUIT
+4 SET X=+($GET(GMTST))
+5 QUIT X
NN(X) ; New Name
+1 NEW GMTSNN,GMTSNI,GMTSNS
+2 SET GMTSNN=$GET(X)
SET GMTSNI=$PIECE(GMTSNN," ",$LENGTH(GMTSNN," "))
+3 SET GMTSNS=$PIECE(GMTSNN," ",1,($LENGTH(GMTSNN," ")-1))
+4 if +GMTSNI=0
SET GMTSNS=GMTSNN
if +GMTSNI=0
SET GMTSNI=1
SET GMTSNI=+GMTSNI+1
+5 SET GMTSNS=$$TRIM(GMTSNS)
+6 if ($LENGTH(GMTSNS)+$LENGTH(GMTSNI))>29
SET GMTSNS=$EXTRACT(GMTSNS,1,30-($LENGTH(GMTSNI)+2))
+7 SET X=$$TRIM(GMTSNS)_" "_GMTSNI
+8 QUIT X
DEL(X) ; Delete Routine X
+1 SET X=$GET(X)
if '$LENGTH(X)
QUIT
if $LENGTH(X)>8
QUIT
if $$ROK(X)=0
QUIT
XECUTE ^%ZOSF("DEL")
QUIT
ROK(X) ; Routine Ok
+1 SET X=$GET(X)
if '$LENGTH(X)
QUIT 0
+2 NEW GMTSEX,GMTSTXT
SET GMTSEX="S GMTSTXT=$T(+1^"_X_")"
XECUTE GMTSEX
if '$LENGTH(GMTSTXT)
QUIT 0
QUIT 1
TX(R,T,L) ; Get Text (Routine/Tag/Line)
+1 NEW GMTSEX,GMTSTXT
SET GMTSEX="S GMTSTXT=$T("_T_"+"_L_"^"_R_")"
XECUTE GMTSEX
SET X=GMTSTXT
+2 QUIT X
TRIM(X) ; Trim Spaces
+1 SET X=$GET(X)
FOR
if $EXTRACT(X,1)'=" "
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+2 FOR
if $EXTRACT(X,$LENGTH(X))'=" "
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+3 SET X=$$UP^XLFSTR($EXTRACT(X,1))_$EXTRACT(X,2,$LENGTH(X))
+4 QUIT X
