- 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
- 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
