GMTSULT7 ; SLC/KER - HS Type Lookup ("B" index) ; 09/21/2001
;;2.7;Health Summary;**30,47**;Oct 20, 1995
;
; External References
; DBIA 10060 ^VA(200
;
Q
B ; Search "B" Index
;
; Needs GMTSEQ and GMTSEO
;
; GMTSEQ=1 Exact match reqired
; Stop search if found
; Continue partial-exact search if not found
;
; GMTSEO=1 Exact match, only one entry
; Stop search if found and return single entry
; Do not continue if not found
;
D CLR^GMTSULT S X=$G(X) Q:'$L(X) N GMTSKL1,GMTSKL2,GMTSIV,GMTSIEN,GMTSDS,GMTSD0,GMTSDW,GMTSC,GMTSE
S GMTSKL1=$$LO($E(X,1)),GMTSKL2=$$UP(GMTSKL1),U="^",(GMTSE,GMTSC)=0
S:$L($G(DIC("S")))&('$L($G(GMTSDICS))) GMTSDICS=$G(DIC("S")),GMTSDS=1
S:$L($G(DIC(0)))&('$L($G(GMTSDIC0))) GMTSDIC0=$G(DIC(0)),GMTSD0=1
S:$L($G(DIC("W")))&('$L($G(GMTSDICW))) GMTSDICW=$G(DIC("W")),GMTSDW=1
D:$G(GMTSDIC0)'["M" CLR^GMTSULT
S GMTSIV=$C($A(GMTSKL1)-1)_"~" F S GMTSIV=$O(^GMT(142,"B",GMTSIV)) Q:GMTSIV=""!($E(GMTSIV,1)'=GMTSKL1) Q:GMTSE D Q:GMTSE
. Q:$$UP($E(X,1,30))'=$$UP($E(GMTSIV,1,$L(X))) S GMTSIEN=0 F S GMTSIEN=$O(^GMT(142,"B",GMTSIV,GMTSIEN)) Q:+GMTSIEN=0 Q:GMTSE D CK Q:GMTSE
S GMTSIV=$C($A(GMTSKL2)-1)_"~" F S GMTSIV=$O(^GMT(142,"B",GMTSIV)) Q:GMTSIV=""!($E(GMTSIV,1)'=GMTSKL2) Q:GMTSE D Q:GMTSE
. Q:$$UP($E(X,1,30))'=$$UP($E(GMTSIV,1,$L(X))) S GMTSIEN=0 F S GMTSIEN=$O(^GMT(142,"B",GMTSIV,GMTSIEN)) Q:+GMTSIEN=0 Q:GMTSE D CK Q:GMTSE
BQ ; Quit "B" Index search
K:+($G(GMTSDS))>0 GMTSDICS K:+($G(GMTSD0))>0 GMTSDIC0 K:+($G(GMTSDW))>0 GMTSDICW
D REO
Q
;
; Build list
CK ; Check Entry
N GMTSCK,GMTSNM,GMTSTL,GMTSOW,GMTSCMP,GMTSOKS,GMTSDT,GMTSDT2 S GMTSTL=$P($G(^GMT(142,+GMTSIEN,"T")),U,1),GMTSNM=$P($G(^GMT(142,+GMTSIEN,0)),U,1)
S GMTSDT=GMTSNM S:$$UP(GMTSNM)'=$$UP(GMTSTL)&($L(GMTSTL)) GMTSDT=GMTSNM_" ("_GMTSTL_")"
S GMTSOW=+($P($G(^GMT(142,+GMTSIEN,0)),U,3)) S:GMTSOW<1 GMTSOW="" S:+GMTSOW>0 GMTSOW=$P($G(^VA(200,+GMTSOW,0)),U,1)
S GMTSCMP=$$CM^GMTSULT2(GMTSIEN) S:$D(GMTSDICW) GMTSDT=GMTSNM S GMTSDT=$$MX(GMTSDT),GMTSOKS=+($$DICS^GMTSULT2($G(GMTSDICS),GMTSNM,+GMTSIEN)) Q:'GMTSOKS S GMTSCK="GMTSNM"
I +($G(GMTSEO)) I $L($G(X))>0,$$UP($G(X))=$$UP($G(GMTSNM)) S GMTSE=1,GMTSCK="GMTSNM" D EA Q
I $L($G(X))>0,$$UP($G(X))=$$UP($G(GMTSNM)) S GMTSCK="GMTSNM" D EA Q
D MA Q
MA ; Add Match
Q:$D(^TMP("GMTSULT2",$J,"IEN",+GMTSIEN))
S GMTSC=+($G(GMTSC))+1,^TMP("GMTSULT2",$J,GMTSC)=$$ASM,^TMP("GMTSULT2",$J,0)=GMTSC,^TMP("GMTSULT2",$J,"B",(GMTSNM_" "),GMTSC)=""
Q
EA ; Add Exact Match
S GMTSC=+($G(GMTSC))+1 S GMTSCMP=$$CM^GMTSULT2(GMTSIEN) S ^TMP("GMTSULT2",$J,"EM")=+GMTSIEN,^TMP("GMTSULT2",$J,"IEN",+GMTSIEN)="",^TMP("GMTSULT2",$J,"B",(GMTSNM_" "),GMTSC)="",^TMP("GMTSULT2",$J,"EMI")=GMTSC
S ^TMP("GMTSULT2",$J,"EMB")=GMTSNM_" ",^TMP("GMTSULT2",$J,GMTSC)=$$ASM,^TMP("GMTSULT2",$J,0)=GMTSC,^TMP("GMTSULT2",$J,"B",(GMTSNM_" "))=""
Q
ASM(X) ; Assemble string to store in list
N GMTST S GMTST=$G(GMTSTL) S:$L($G(GMTSDT))&($G(GMTSDT)'=$G(GMTST)) GMTST=GMTSDT
S X=+($G(GMTSIEN)),X=X_U_$G(GMTSNM)_U_$G(GMTSTL)_U_$G(GMTSOW)_U_U_$G(GMTSCMP)_U_GMTST
Q X
;
REO ; Reorder List
N GMTSC,GMTSFND,GMTSG,GMTSI,GMTSIEN,GMTSKEY,GMTSL,GMTSCMP,GMTSOW,GMTSTTL,GMTSLOC,GMTSMN,GMTSNM
S GMTSI=0,GMTSFND=""
; Add exact match to the top of the selection list
I '$D(^TMP("GMTSULT2",$J,"EMI")),+($G(GMTSEO)) K ^TMP("GMTSULT2",$J)
I $D(^TMP("GMTSULT2",$J,"EMI")) D
. S GMTSI=0,GMTSC=$G(^TMP("GMTSULT2",$J,"EMI")) D ADD
. S ^TMP("GMTSULT",$J,0)=GMTSI K ^TMP("GMTSULT2",$J,"EMI")
. ; Kill global (quit) if Exact Match is found
. ; and DIR(0) either contains OE or X
. K:+($G(GMTSEQ)) ^TMP("GMTSULT2",$J) K:+($G(GMTSEO)) ^TMP("GMTSULT2",$J)
; Kill global (quit) if Exact Match is not
; found and DIR(0)["OE"
I '$D(^TMP("GMTSULT2",$J,"EMI")),+($G(GMTSEO)) K ^TMP("GMTSULT2",$J)
; Add other entries in Alphabetical Order
S GMTSFND=0 Q:'$D(^TMP("GMTSULT2",$J,"B")) F S GMTSFND=$O(^TMP("GMTSULT2",$J,"B",GMTSFND)) Q:GMTSFND="" D
. S GMTSC=0 F S GMTSC=$O(^TMP("GMTSULT2",$J,"B",GMTSFND,GMTSC)) Q:+GMTSC=0 D ADD
D CLEAN^GMTSULT
Q
ADD ; Add to the reordered list
N GMTS0,GMTS1,GMTS2,GMTS3,GMTS4,GMTS5,GMTS6,GMTS7
S GMTSI=+($G(GMTSI))+1,GMTS0=$G(^TMP("GMTSULT2",$J,GMTSC)) S (GMTSG,GMTSMN,GMTS2)=$$MX($P(GMTS0,U,2)) S (GMTS1,GMTSIEN)=+($P(GMTS0,U,1)) S GMTSNM=$$UP(GMTSMN)
S (GMTS4,GMTSOW)=$$MX($P(GMTS0,U,4)),GMTSOW=GMTSOW_")" S (GMTS3,GMTSTTL)=$$MX($P(GMTS0,U,3)),GMTSTTL=GMTSTTL_")" S (GMTS5,GMTSLOC)=$$MX($P(GMTS0,U,5)),GMTSLOC=GMTSLOC_")"
S (GMTS6,GMTSCMP)=$P(GMTS0,U,6),GMTSL=$P(GMTS0,U,4),GMTSG=$P(GMTS0,U,7)
S:$L(GMTSG)&(GMTSG'[")")&(GMTSG'["(")&(+GMTS6=0)&($L(GMTS6)) GMTSG=GMTSG_" ("_GMTS6_")"
S GMTS7=GMTSG S ^TMP("GMTSULT",$J,GMTSI)=GMTS1_U_GMTS2_U_GMTS3_U_GMTS4_U_GMTS5_U_GMTS6_U_GMTS7
S ^TMP("GMTSULT",$J,0)=GMTSI
Q
;
; Miscellaneous
UP(X) ; Uppercase
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
LO(X) ; Lowercase
Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
MX(X) ; Mix Case
Q $$EN^GMTSUMX(X)
DUP(X) ; Check for Duplicate
S X=$G(X) Q:'$L(X) 0 N GMTSE,GMTSI S (GMTSE,GMTSI)=0
F S GMTSI=$O(^GMT(142,"B",$E(X,1,30),GMTSI)) Q:+GMTSI=0 D Q:GMTSE
. S GMTSN=$P($G(^GMT(142,+GMTSI,0)),"^",1) S:$$UP^GMTSULT2(X)=$$UP^GMTSULT2(GMTSN) GMTSE=1
S X=+($G(GMTSE)) Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSULT7 5564 printed Sep 23, 2025@19:36:39 Page 2
GMTSULT7 ; SLC/KER - HS Type Lookup ("B" index) ; 09/21/2001
+1 ;;2.7;Health Summary;**30,47**;Oct 20, 1995
+2 ;
+3 ; External References
+4 ; DBIA 10060 ^VA(200
+5 ;
+6 QUIT
B ; Search "B" Index
+1 ;
+2 ; Needs GMTSEQ and GMTSEO
+3 ;
+4 ; GMTSEQ=1 Exact match reqired
+5 ; Stop search if found
+6 ; Continue partial-exact search if not found
+7 ;
+8 ; GMTSEO=1 Exact match, only one entry
+9 ; Stop search if found and return single entry
+10 ; Do not continue if not found
+11 ;
+12 DO CLR^GMTSULT
SET X=$GET(X)
if '$LENGTH(X)
QUIT
NEW GMTSKL1,GMTSKL2,GMTSIV,GMTSIEN,GMTSDS,GMTSD0,GMTSDW,GMTSC,GMTSE
+13 SET GMTSKL1=$$LO($EXTRACT(X,1))
SET GMTSKL2=$$UP(GMTSKL1)
SET U="^"
SET (GMTSE,GMTSC)=0
+14 if $LENGTH($GET(DIC("S")))&('$LENGTH($GET(GMTSDICS)))
SET GMTSDICS=$GET(DIC("S"))
SET GMTSDS=1
+15 if $LENGTH($GET(DIC(0)))&('$LENGTH($GET(GMTSDIC0)))
SET GMTSDIC0=$GET(DIC(0))
SET GMTSD0=1
+16 if $LENGTH($GET(DIC("W")))&('$LENGTH($GET(GMTSDICW)))
SET GMTSDICW=$GET(DIC("W"))
SET GMTSDW=1
+17 if $GET(GMTSDIC0)'["M"
DO CLR^GMTSULT
+18 SET GMTSIV=$CHAR($ASCII(GMTSKL1)-1)_"~"
FOR
SET GMTSIV=$ORDER(^GMT(142,"B",GMTSIV))
if GMTSIV=""!($EXTRACT(GMTSIV,1)'=GMTSKL1)
QUIT
if GMTSE
QUIT
Begin DoDot:1
+19 if $$UP($EXTRACT(X,1,30))'=$$UP($EXTRACT(GMTSIV,1,$LENGTH(X)))
QUIT
SET GMTSIEN=0
FOR
SET GMTSIEN=$ORDER(^GMT(142,"B",GMTSIV,GMTSIEN))
if +GMTSIEN=0
QUIT
if GMTSE
QUIT
DO CK
if GMTSE
QUIT
End DoDot:1
if GMTSE
QUIT
+20 SET GMTSIV=$CHAR($ASCII(GMTSKL2)-1)_"~"
FOR
SET GMTSIV=$ORDER(^GMT(142,"B",GMTSIV))
if GMTSIV=""!($EXTRACT(GMTSIV,1)'=GMTSKL2)
QUIT
if GMTSE
QUIT
Begin DoDot:1
+21 if $$UP($EXTRACT(X,1,30))'=$$UP($EXTRACT(GMTSIV,1,$LENGTH(X)))
QUIT
SET GMTSIEN=0
FOR
SET GMTSIEN=$ORDER(^GMT(142,"B",GMTSIV,GMTSIEN))
if +GMTSIEN=0
QUIT
if GMTSE
QUIT
DO CK
if GMTSE
QUIT
End DoDot:1
if GMTSE
QUIT
BQ ; Quit "B" Index search
+1 if +($GET(GMTSDS))>0
KILL GMTSDICS
if +($GET(GMTSD0))>0
KILL GMTSDIC0
if +($GET(GMTSDW))>0
KILL GMTSDICW
+2 DO REO
+3 QUIT
+4 ;
+5 ; Build list
CK ; Check Entry
+1 NEW GMTSCK,GMTSNM,GMTSTL,GMTSOW,GMTSCMP,GMTSOKS,GMTSDT,GMTSDT2
SET GMTSTL=$PIECE($GET(^GMT(142,+GMTSIEN,"T")),U,1)
SET GMTSNM=$PIECE($GET(^GMT(142,+GMTSIEN,0)),U,1)
+2 SET GMTSDT=GMTSNM
if $$UP(GMTSNM)'=$$UP(GMTSTL)&($LENGTH(GMTSTL))
SET GMTSDT=GMTSNM_" ("_GMTSTL_")"
+3 SET GMTSOW=+($PIECE($GET(^GMT(142,+GMTSIEN,0)),U,3))
if GMTSOW<1
SET GMTSOW=""
if +GMTSOW>0
SET GMTSOW=$PIECE($GET(^VA(200,+GMTSOW,0)),U,1)
+4 SET GMTSCMP=$$CM^GMTSULT2(GMTSIEN)
if $DATA(GMTSDICW)
SET GMTSDT=GMTSNM
SET GMTSDT=$$MX(GMTSDT)
SET GMTSOKS=+($$DICS^GMTSULT2($GET(GMTSDICS),GMTSNM,+GMTSIEN))
if 'GMTSOKS
QUIT
SET GMTSCK="GMTSNM"
+5 IF +($GET(GMTSEO))
IF $LENGTH($GET(X))>0
IF $$UP($GET(X))=$$UP($GET(GMTSNM))
SET GMTSE=1
SET GMTSCK="GMTSNM"
DO EA
QUIT
+6 IF $LENGTH($GET(X))>0
IF $$UP($GET(X))=$$UP($GET(GMTSNM))
SET GMTSCK="GMTSNM"
DO EA
QUIT
+7 DO MA
QUIT
MA ; Add Match
+1 if $DATA(^TMP("GMTSULT2",$JOB,"IEN",+GMTSIEN))
QUIT
+2 SET GMTSC=+($GET(GMTSC))+1
SET ^TMP("GMTSULT2",$JOB,GMTSC)=$$ASM
SET ^TMP("GMTSULT2",$JOB,0)=GMTSC
SET ^TMP("GMTSULT2",$JOB,"B",(GMTSNM_" "),GMTSC)=""
+3 QUIT
EA ; Add Exact Match
+1 SET GMTSC=+($GET(GMTSC))+1
SET GMTSCMP=$$CM^GMTSULT2(GMTSIEN)
SET ^TMP("GMTSULT2",$JOB,"EM")=+GMTSIEN
SET ^TMP("GMTSULT2",$JOB,"IEN",+GMTSIEN)=""
SET ^TMP("GMTSULT2",$JOB,"B",(GMTSNM_" "),GMTSC)=""
SET ^TMP("GMTSULT2",$JOB,"EMI")=GMTSC
+2 SET ^TMP("GMTSULT2",$JOB,"EMB")=GMTSNM_" "
SET ^TMP("GMTSULT2",$JOB,GMTSC)=$$ASM
SET ^TMP("GMTSULT2",$JOB,0)=GMTSC
SET ^TMP("GMTSULT2",$JOB,"B",(GMTSNM_" "))=""
+3 QUIT
ASM(X) ; Assemble string to store in list
+1 NEW GMTST
SET GMTST=$GET(GMTSTL)
if $LENGTH($GET(GMTSDT))&($GET(GMTSDT)'=$GET(GMTST))
SET GMTST=GMTSDT
+2 SET X=+($GET(GMTSIEN))
SET X=X_U_$GET(GMTSNM)_U_$GET(GMTSTL)_U_$GET(GMTSOW)_U_U_$GET(GMTSCMP)_U_GMTST
+3 QUIT X
+4 ;
REO ; Reorder List
+1 NEW GMTSC,GMTSFND,GMTSG,GMTSI,GMTSIEN,GMTSKEY,GMTSL,GMTSCMP,GMTSOW,GMTSTTL,GMTSLOC,GMTSMN,GMTSNM
+2 SET GMTSI=0
SET GMTSFND=""
+3 ; Add exact match to the top of the selection list
+4 IF '$DATA(^TMP("GMTSULT2",$JOB,"EMI"))
IF +($GET(GMTSEO))
KILL ^TMP("GMTSULT2",$JOB)
+5 IF $DATA(^TMP("GMTSULT2",$JOB,"EMI"))
Begin DoDot:1
+6 SET GMTSI=0
SET GMTSC=$GET(^TMP("GMTSULT2",$JOB,"EMI"))
DO ADD
+7 SET ^TMP("GMTSULT",$JOB,0)=GMTSI
KILL ^TMP("GMTSULT2",$JOB,"EMI")
+8 ; Kill global (quit) if Exact Match is found
+9 ; and DIR(0) either contains OE or X
+10 if +($GET(GMTSEQ))
KILL ^TMP("GMTSULT2",$JOB)
if +($GET(GMTSEO))
KILL ^TMP("GMTSULT2",$JOB)
End DoDot:1
+11 ; Kill global (quit) if Exact Match is not
+12 ; found and DIR(0)["OE"
+13 IF '$DATA(^TMP("GMTSULT2",$JOB,"EMI"))
IF +($GET(GMTSEO))
KILL ^TMP("GMTSULT2",$JOB)
+14 ; Add other entries in Alphabetical Order
+15 SET GMTSFND=0
if '$DATA(^TMP("GMTSULT2",$JOB,"B"))
QUIT
FOR
SET GMTSFND=$ORDER(^TMP("GMTSULT2",$JOB,"B",GMTSFND))
if GMTSFND=""
QUIT
Begin DoDot:1
+16 SET GMTSC=0
FOR
SET GMTSC=$ORDER(^TMP("GMTSULT2",$JOB,"B",GMTSFND,GMTSC))
if +GMTSC=0
QUIT
DO ADD
End DoDot:1
+17 DO CLEAN^GMTSULT
+18 QUIT
ADD ; Add to the reordered list
+1 NEW GMTS0,GMTS1,GMTS2,GMTS3,GMTS4,GMTS5,GMTS6,GMTS7
+2 SET GMTSI=+($GET(GMTSI))+1
SET GMTS0=$GET(^TMP("GMTSULT2",$JOB,GMTSC))
SET (GMTSG,GMTSMN,GMTS2)=$$MX($PIECE(GMTS0,U,2))
SET (GMTS1,GMTSIEN)=+($PIECE(GMTS0,U,1))
SET GMTSNM=$$UP(GMTSMN)
+3 SET (GMTS4,GMTSOW)=$$MX($PIECE(GMTS0,U,4))
SET GMTSOW=GMTSOW_")"
SET (GMTS3,GMTSTTL)=$$MX($PIECE(GMTS0,U,3))
SET GMTSTTL=GMTSTTL_")"
SET (GMTS5,GMTSLOC)=$$MX($PIECE(GMTS0,U,5))
SET GMTSLOC=GMTSLOC_")"
+4 SET (GMTS6,GMTSCMP)=$PIECE(GMTS0,U,6)
SET GMTSL=$PIECE(GMTS0,U,4)
SET GMTSG=$PIECE(GMTS0,U,7)
+5 if $LENGTH(GMTSG)&(GMTSG'[")")&(GMTSG'["(")&(+GMTS6=0)&($LENGTH(GMTS6))
SET GMTSG=GMTSG_" ("_GMTS6_")"
+6 SET GMTS7=GMTSG
SET ^TMP("GMTSULT",$JOB,GMTSI)=GMTS1_U_GMTS2_U_GMTS3_U_GMTS4_U_GMTS5_U_GMTS6_U_GMTS7
+7 SET ^TMP("GMTSULT",$JOB,0)=GMTSI
+8 QUIT
+9 ;
+10 ; Miscellaneous
UP(X) ; Uppercase
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
LO(X) ; Lowercase
+1 QUIT $TRANSLATE(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
MX(X) ; Mix Case
+1 QUIT $$EN^GMTSUMX(X)
DUP(X) ; Check for Duplicate
+1 SET X=$GET(X)
if '$LENGTH(X)
QUIT 0
NEW GMTSE,GMTSI
SET (GMTSE,GMTSI)=0
+2 FOR
SET GMTSI=$ORDER(^GMT(142,"B",$EXTRACT(X,1,30),GMTSI))
if +GMTSI=0
QUIT
Begin DoDot:1
+3 SET GMTSN=$PIECE($GET(^GMT(142,+GMTSI,0)),"^",1)
if $$UP^GMTSULT2(X)=$$UP^GMTSULT2(GMTSN)
SET GMTSE=1
End DoDot:1
if GMTSE
QUIT
+4 SET X=+($GET(GMTSE))
QUIT X
