GMTSULT6 ; SLC/KER - HS Type Lookup (Select) ; 08/27/2002
;;2.7;Health Summary;**30,32,56**;Oct 20, 1995
;
; External References
; DBIA 10026 ^DIR
; DBIA 10006 ^DIC (file #142)
; DBIA 10060 ^VA(200,
; DBIA 2056 $$GET1^DIQ (file #200)
; DBIA 10016 ^DIM
; DBIA 2055 RECALL^DILFD
Q
;
MULTI ; Selection when Multiple Entries are found
I $L($G(GMTSDICB)),GMTSDEF=1 D DEF Q
S GMTSDICW=$$DICW($G(GMTSDICW)) K:'$L(GMTSDICW) GMTSDICW
N GMTSIEN,GMTSE,GMTSO,GMTST,GMTSTOT,GMTSM S GMTSTOT=^TMP("GMTSULT",$J,0) Q:+GMTSTOT=0 I +GMTSTOT=1 D ONE Q
W ! W:+GMTSTOT>1 !,GMTSTOT," Health Summary Types found"
N GMTSI,GMTSS,GMTSEX,X,GMTSTR,GMTSTR2,GMTSTR3,GMTSLEN S GMTSLEN=75,GMTSS=0,GMTSEX=0
; List 5 at a time
F GMTSI=1:1:^TMP("GMTSULT",$J,0) Q:((GMTSS>0)&(GMTSS<GMTSI+1)) Q:GMTSEX D Q:GMTSEX
. S GMTSE=$G(^TMP("GMTSULT",$J,GMTSI))
. S GMTSM=GMTSI W:GMTSI#5=1 ! W !,$J(GMTSI,4),". "
. S GMTSIEN=+GMTSE,(GMTST,GMTSTR)=$P(GMTSE,U,7),GMTSO=$P(GMTSE,U,2)
. S:'$L(GMTSTR)&($L(GMTSO)) GMTSTR=GMTSO
. D WRM1
. W:GMTSI#5=0 ! S:GMTSI#5=0 GMTSS=$$SEL(GMTSM) S:GMTSS["^" GMTSEX=1
I GMTSI#5'=0,+GMTSS=0 W ! S GMTSS=$$SEL(GMTSM) S:GMTSS["^" GMTSEX=1
I 'GMTSEX,+GMTSS>0 D Q
. N GMTSNAM K Y S Y=+($G(^TMP("GMTSULT",$J,+GMTSS)))
. S GMTSNAM=$P($G(^GMT(142,+Y,0)),"^",1) I '$L(GMTSNAM) K Y S Y=-1 Q
. D Y(+Y)
K Y S Y=-1
Q
WRM1 ; Write one entry of muli selection
N Y,GMTS S Y=+GMTSIEN,GMTS=$G(^GMT(142,+Y,0))
I '$D(GMTSDICW) W:$L(GMTSTR)'>GMTSLEN GMTSTR D:$L(GMTSTR)>GMTSLEN LONG Q
I $D(GMTSDICW),$G(GMTSDIC0)'["S" W $P(GMTS,"^",1)," " X GMTSDICW Q
I $D(GMTSDICW),$G(GMTSDIC0)["S" X GMTSDICW Q
Q
SEL(X) ; Select multiple
N Y,GMTSM,DTOUT,DUOUT,DIRUT,DIROUT S GMTSM=+($G(X)) Q:GMTSM=0 -1
S:+($O(^TMP("GMTSULT",$J,+($G(GMTSI)))))>0 DIR("A")="Press <RETURN> for more, '^' to exit, or Select 1-"_GMTSM_": "
S:+($O(^TMP("GMTSULT",$J,+($G(GMTSI)))))'>0 DIR("A")="Select 1-"_GMTSM_": "
S (DIR("?"),DIR("??"))="Answer must be from 1 to "_GMTSM_", or <Return> to continue "
S DIR(0)="NAO^1:"_GMTSM_":0" D ^DIR S:$D(DTOUT)!(X[U) X=U K DIR Q X
Q
;
ONE ; One entry on the selection list
I $L($G(GMTSDICB)),GMTSDEF=1 D DEF Q
N GMTSEX,GMTSIEN,GMTSTR,GMTSTR2,GMTSY,GMTSX,GMTSLEN,DIR,X
S GMTSLEN=75,Y=0 S:GMTSQ!($G(GMTSDIC0)["E") GMTSQ=1,Y=1
S GMTSEX=0
; No Echo or if Ask
S GMTSIEN=+($G(^TMP("GMTSULT",$J,1)))
I 'GMTSQ!($G(GMTSDIC0)["A") D
. N X S GMTSTR=$P($G(^TMP("GMTSULT",$J,1)),U,7)
. S:'$L(GMTSTR) GMTSTR=$P($G(^TMP("GMTSULT",$J,1)),U,2)
. D WRO1 S Y=$$OK S:Y["^" GMTSEX=1
I 'GMTSEX,+Y>0 D Q
. N GMTSNAM K Y S Y=+($G(^TMP("GMTSULT",$J,1)))
. S GMTSNAM=$P($G(^GMT(142,+Y,0)),"^",1) I '$L(GMTSNAM) K Y S Y=-1 Q
. D Y(+Y)
K Y S Y=-1
Q
WRO1 ; Write one entry of single selection
W !!," " N Y,GMTS S Y=+GMTSIEN,GMTS=$G(^GMT(142,+Y,0))
I '$D(GMTSDICW) W:$L(GMTSTR)'>GMTSLEN GMTSTR D:$L(GMTSTR)>GMTSLEN LONG W ! Q
I $D(GMTSDICW),$G(GMTSDIC0)'["S" W $P(GMTS,"^",1)," " X GMTSDICW W ! Q
I $D(GMTSDICW),$G(GMTSDIC0)["S" X GMTSDICW W ! Q
Q
OK(X) ; Select one if DIC(0)["A" Ask OK
N DIR,DTOUT,DUOUT,DIROUT S DIR(0)="YAO",DIR("B")="YES"
S DIR("A")=" OK? " D ^DIR S:X'["^" X=+Y S:$D(DTOUT)!($D(DUOUT)) X="^" S:X["^" X="^" Q X
;
DEF ; Select Default Entry
N GMTSNAM K Y S Y=+($G(^TMP("GMTSULT",$J,1)))
S GMTSNAM=$P($G(^GMT(142,+Y,0)),"^",1) I '$L(GMTSNAM) K Y S Y=-1 Q
D Y(+Y)
Q
;
; Display
LONG ; Handle a long string
N GMTSP,GMTSOK,GMTSCHR,GMTSPSN,GMTSTO,GMTSREM,GMTSLN,GMTSOLD S GMTSLN=0,GMTSOLD=GMTSTR,GMTSP=5
F Q:$L(GMTSTR)<(GMTSLEN+1) D PARSE Q:$L(GMTSTR)<(GMTSLEN+1)
S GMTSLN=GMTSLN+1 W:GMTSLN>1 ! W ?GMTSP,GMTSTR
Q
PARSE ; Parse a long string to screen length
S GMTSOK=0,GMTSCHR="" F GMTSPSN=GMTSLEN:-1:0 Q:+GMTSOK=1 D Q:+GMTSOK=1
. I $E(GMTSTR,GMTSPSN)=" " S GMTSCHR=" ",GMTSOK=1 Q
. I $E(GMTSTR,GMTSPSN)="," S GMTSCHR=",",GMTSOK=1 Q
. I $E(GMTSTR,GMTSPSN)="/" S GMTSCHR="/",GMTSOK=1 Q
. I $E(GMTSTR,GMTSPSN)="-" S GMTSCHR="-",GMTSOK=1 Q
I GMTSCHR=" " S GMTSTO=$E(GMTSTR,1,GMTSPSN-1),GMTSREM=$E(GMTSTR,GMTSPSN+1,$L(GMTSTR))
I GMTSCHR="," S GMTSTO=$E(GMTSTR,1,GMTSPSN),GMTSREM=$E(GMTSTR,(GMTSPSN+1),$L(GMTSTR)) S:$E(GMTSREM,1)=" " GMTSREM=$E(GMTSREM,2,$L(GMTSREM))
I GMTSCHR="/" S GMTSTO=$E(GMTSTR,1,GMTSPSN),GMTSREM=$E(GMTSTR,(GMTSPSN+1),$L(GMTSTR)) S:$E(GMTSREM,1)=" " GMTSREM=$E(GMTSREM,2,$L(GMTSREM))
I GMTSCHR="-" S GMTSTO=$E(GMTSTR,1,GMTSPSN),GMTSREM=$E(GMTSTR,(GMTSPSN+1),$L(GMTSTR)) S:$E(GMTSREM,1)=" " GMTSREM=$E(GMTSREM,2,$L(GMTSREM))
S GMTSTR=GMTSREM,GMTSLN=GMTSLN+1 W:GMTSLN>1 ! W ?GMTSP,GMTSTO
Q
DICW(X) ; Check for valid DIC("W")
S X=$G(X) Q:'$L(X) ""
D ^DIM I '$D(X) Q ""
Q X
;
; Post Selection
Y(X) ; Set Y
K Y S X=+($G(X))
S:X'>0!('$D(^GMT(142,+X,0))) Y=-1 Q:X'>0!('$D(^GMT(142,+X,0)))
S Y=+X_"^"_$P($G(^GMT(142,+X,0)),"^",1)
S:$G(GMTSDIC0)["Z"!($G(DIC(0))["Z") Y(0)=$G(^GMT(142,+X,0)),Y(0,0)=$P($G(^GMT(142,+X,0)),"^",1),Y(0,1)=$$MX(Y(0,0))
I +($G(GMTSWY))=0 W:$G(GMTSDIC0)["E"!($G(DIC(0))["E") " ",$P($G(^GMT(142,+X,0)),"^",1) S GMTSWY=1
D:$G(GMTSDIC0)'["F"&($G(DIC(0))'["F") SDISV
Q
SDISV ; Save Default Value (Spacebar-Return)
Q:$G(GMTSDIC0)["F" Q:+($G(DUZ))=0 Q:'$L($$GET1^DIQ(200,(+($G(DUZ))_","),.01)) Q:+($G(Y))=0 Q:'$D(^GMT(142,+($G(Y)),0))
D RECALL^DILFD(142,+($G(Y))_",",+($G(DUZ))) Q
Q
MX(X) ; Mix Case
Q $$EN^GMTSUMX(X)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSULT6 5516 printed Dec 13, 2024@02:00:33 Page 2
GMTSULT6 ; SLC/KER - HS Type Lookup (Select) ; 08/27/2002
+1 ;;2.7;Health Summary;**30,32,56**;Oct 20, 1995
+2 ;
+3 ; External References
+4 ; DBIA 10026 ^DIR
+5 ; DBIA 10006 ^DIC (file #142)
+6 ; DBIA 10060 ^VA(200,
+7 ; DBIA 2056 $$GET1^DIQ (file #200)
+8 ; DBIA 10016 ^DIM
+9 ; DBIA 2055 RECALL^DILFD
+10 QUIT
+11 ;
MULTI ; Selection when Multiple Entries are found
+1 IF $LENGTH($GET(GMTSDICB))
IF GMTSDEF=1
DO DEF
QUIT
+2 SET GMTSDICW=$$DICW($GET(GMTSDICW))
if '$LENGTH(GMTSDICW)
KILL GMTSDICW
+3 NEW GMTSIEN,GMTSE,GMTSO,GMTST,GMTSTOT,GMTSM
SET GMTSTOT=^TMP("GMTSULT",$JOB,0)
if +GMTSTOT=0
QUIT
IF +GMTSTOT=1
DO ONE
QUIT
+4 WRITE !
if +GMTSTOT>1
WRITE !,GMTSTOT," Health Summary Types found"
+5 NEW GMTSI,GMTSS,GMTSEX,X,GMTSTR,GMTSTR2,GMTSTR3,GMTSLEN
SET GMTSLEN=75
SET GMTSS=0
SET GMTSEX=0
+6 ; List 5 at a time
+7 FOR GMTSI=1:1:^TMP("GMTSULT",$JOB,0)
if ((GMTSS>0)&(GMTSS<GMTSI+1))
QUIT
if GMTSEX
QUIT
Begin DoDot:1
+8 SET GMTSE=$GET(^TMP("GMTSULT",$JOB,GMTSI))
+9 SET GMTSM=GMTSI
if GMTSI#5=1
WRITE !
WRITE !,$JUSTIFY(GMTSI,4),". "
+10 SET GMTSIEN=+GMTSE
SET (GMTST,GMTSTR)=$PIECE(GMTSE,U,7)
SET GMTSO=$PIECE(GMTSE,U,2)
+11 if '$LENGTH(GMTSTR)&($LENGTH(GMTSO))
SET GMTSTR=GMTSO
+12 DO WRM1
+13 if GMTSI#5=0
WRITE !
if GMTSI#5=0
SET GMTSS=$$SEL(GMTSM)
if GMTSS["^"
SET GMTSEX=1
End DoDot:1
if GMTSEX
QUIT
+14 IF GMTSI#5'=0
IF +GMTSS=0
WRITE !
SET GMTSS=$$SEL(GMTSM)
if GMTSS["^"
SET GMTSEX=1
+15 IF 'GMTSEX
IF +GMTSS>0
Begin DoDot:1
+16 NEW GMTSNAM
KILL Y
SET Y=+($GET(^TMP("GMTSULT",$JOB,+GMTSS)))
+17 SET GMTSNAM=$PIECE($GET(^GMT(142,+Y,0)),"^",1)
IF '$LENGTH(GMTSNAM)
KILL Y
SET Y=-1
QUIT
+18 DO Y(+Y)
End DoDot:1
QUIT
+19 KILL Y
SET Y=-1
+20 QUIT
WRM1 ; Write one entry of muli selection
+1 NEW Y,GMTS
SET Y=+GMTSIEN
SET GMTS=$GET(^GMT(142,+Y,0))
+2 IF '$DATA(GMTSDICW)
if $LENGTH(GMTSTR)'>GMTSLEN
WRITE GMTSTR
if $LENGTH(GMTSTR)>GMTSLEN
DO LONG
QUIT
+3 IF $DATA(GMTSDICW)
IF $GET(GMTSDIC0)'["S"
WRITE $PIECE(GMTS,"^",1)," "
XECUTE GMTSDICW
QUIT
+4 IF $DATA(GMTSDICW)
IF $GET(GMTSDIC0)["S"
XECUTE GMTSDICW
QUIT
+5 QUIT
SEL(X) ; Select multiple
+1 NEW Y,GMTSM,DTOUT,DUOUT,DIRUT,DIROUT
SET GMTSM=+($GET(X))
if GMTSM=0
QUIT -1
+2 if +($ORDER(^TMP("GMTSULT",$JOB,+($GET(GMTSI)))))>0
SET DIR("A")="Press <RETURN> for more, '^' to exit, or Select 1-"_GMTSM_": "
+3 if +($ORDER(^TMP("GMTSULT",$JOB,+($GET(GMTSI)))))'>0
SET DIR("A")="Select 1-"_GMTSM_": "
+4 SET (DIR("?"),DIR("??"))="Answer must be from 1 to "_GMTSM_", or <Return> to continue "
+5 SET DIR(0)="NAO^1:"_GMTSM_":0"
DO ^DIR
if $DATA(DTOUT)!(X[U)
SET X=U
KILL DIR
QUIT X
+6 QUIT
+7 ;
ONE ; One entry on the selection list
+1 IF $LENGTH($GET(GMTSDICB))
IF GMTSDEF=1
DO DEF
QUIT
+2 NEW GMTSEX,GMTSIEN,GMTSTR,GMTSTR2,GMTSY,GMTSX,GMTSLEN,DIR,X
+3 SET GMTSLEN=75
SET Y=0
if GMTSQ!($GET(GMTSDIC0)["E")
SET GMTSQ=1
SET Y=1
+4 SET GMTSEX=0
+5 ; No Echo or if Ask
+6 SET GMTSIEN=+($GET(^TMP("GMTSULT",$JOB,1)))
+7 IF 'GMTSQ!($GET(GMTSDIC0)["A")
Begin DoDot:1
+8 NEW X
SET GMTSTR=$PIECE($GET(^TMP("GMTSULT",$JOB,1)),U,7)
+9 if '$LENGTH(GMTSTR)
SET GMTSTR=$PIECE($GET(^TMP("GMTSULT",$JOB,1)),U,2)
+10 DO WRO1
SET Y=$$OK
if Y["^"
SET GMTSEX=1
End DoDot:1
+11 IF 'GMTSEX
IF +Y>0
Begin DoDot:1
+12 NEW GMTSNAM
KILL Y
SET Y=+($GET(^TMP("GMTSULT",$JOB,1)))
+13 SET GMTSNAM=$PIECE($GET(^GMT(142,+Y,0)),"^",1)
IF '$LENGTH(GMTSNAM)
KILL Y
SET Y=-1
QUIT
+14 DO Y(+Y)
End DoDot:1
QUIT
+15 KILL Y
SET Y=-1
+16 QUIT
WRO1 ; Write one entry of single selection
+1 WRITE !!," "
NEW Y,GMTS
SET Y=+GMTSIEN
SET GMTS=$GET(^GMT(142,+Y,0))
+2 IF '$DATA(GMTSDICW)
if $LENGTH(GMTSTR)'>GMTSLEN
WRITE GMTSTR
if $LENGTH(GMTSTR)>GMTSLEN
DO LONG
WRITE !
QUIT
+3 IF $DATA(GMTSDICW)
IF $GET(GMTSDIC0)'["S"
WRITE $PIECE(GMTS,"^",1)," "
XECUTE GMTSDICW
WRITE !
QUIT
+4 IF $DATA(GMTSDICW)
IF $GET(GMTSDIC0)["S"
XECUTE GMTSDICW
WRITE !
QUIT
+5 QUIT
OK(X) ; Select one if DIC(0)["A" Ask OK
+1 NEW DIR,DTOUT,DUOUT,DIROUT
SET DIR(0)="YAO"
SET DIR("B")="YES"
+2 SET DIR("A")=" OK? "
DO ^DIR
if X'["^"
SET X=+Y
if $DATA(DTOUT)!($DATA(DUOUT))
SET X="^"
if X["^"
SET X="^"
QUIT X
+3 ;
DEF ; Select Default Entry
+1 NEW GMTSNAM
KILL Y
SET Y=+($GET(^TMP("GMTSULT",$JOB,1)))
+2 SET GMTSNAM=$PIECE($GET(^GMT(142,+Y,0)),"^",1)
IF '$LENGTH(GMTSNAM)
KILL Y
SET Y=-1
QUIT
+3 DO Y(+Y)
+4 QUIT
+5 ;
+6 ; Display
LONG ; Handle a long string
+1 NEW GMTSP,GMTSOK,GMTSCHR,GMTSPSN,GMTSTO,GMTSREM,GMTSLN,GMTSOLD
SET GMTSLN=0
SET GMTSOLD=GMTSTR
SET GMTSP=5
+2 FOR
if $LENGTH(GMTSTR)<(GMTSLEN+1)
QUIT
DO PARSE
if $LENGTH(GMTSTR)<(GMTSLEN+1)
QUIT
+3 SET GMTSLN=GMTSLN+1
if GMTSLN>1
WRITE !
WRITE ?GMTSP,GMTSTR
+4 QUIT
PARSE ; Parse a long string to screen length
+1 SET GMTSOK=0
SET GMTSCHR=""
FOR GMTSPSN=GMTSLEN:-1:0
if +GMTSOK=1
QUIT
Begin DoDot:1
+2 IF $EXTRACT(GMTSTR,GMTSPSN)=" "
SET GMTSCHR=" "
SET GMTSOK=1
QUIT
+3 IF $EXTRACT(GMTSTR,GMTSPSN)=","
SET GMTSCHR=","
SET GMTSOK=1
QUIT
+4 IF $EXTRACT(GMTSTR,GMTSPSN)="/"
SET GMTSCHR="/"
SET GMTSOK=1
QUIT
+5 IF $EXTRACT(GMTSTR,GMTSPSN)="-"
SET GMTSCHR="-"
SET GMTSOK=1
QUIT
End DoDot:1
if +GMTSOK=1
QUIT
+6 IF GMTSCHR=" "
SET GMTSTO=$EXTRACT(GMTSTR,1,GMTSPSN-1)
SET GMTSREM=$EXTRACT(GMTSTR,GMTSPSN+1,$LENGTH(GMTSTR))
+7 IF GMTSCHR=","
SET GMTSTO=$EXTRACT(GMTSTR,1,GMTSPSN)
SET GMTSREM=$EXTRACT(GMTSTR,(GMTSPSN+1),$LENGTH(GMTSTR))
if $EXTRACT(GMTSREM,1)=" "
SET GMTSREM=$EXTRACT(GMTSREM,2,$LENGTH(GMTSREM))
+8 IF GMTSCHR="/"
SET GMTSTO=$EXTRACT(GMTSTR,1,GMTSPSN)
SET GMTSREM=$EXTRACT(GMTSTR,(GMTSPSN+1),$LENGTH(GMTSTR))
if $EXTRACT(GMTSREM,1)=" "
SET GMTSREM=$EXTRACT(GMTSREM,2,$LENGTH(GMTSREM))
+9 IF GMTSCHR="-"
SET GMTSTO=$EXTRACT(GMTSTR,1,GMTSPSN)
SET GMTSREM=$EXTRACT(GMTSTR,(GMTSPSN+1),$LENGTH(GMTSTR))
if $EXTRACT(GMTSREM,1)=" "
SET GMTSREM=$EXTRACT(GMTSREM,2,$LENGTH(GMTSREM))
+10 SET GMTSTR=GMTSREM
SET GMTSLN=GMTSLN+1
if GMTSLN>1
WRITE !
WRITE ?GMTSP,GMTSTO
+11 QUIT
DICW(X) ; Check for valid DIC("W")
+1 SET X=$GET(X)
if '$LENGTH(X)
QUIT ""
+2 DO ^DIM
IF '$DATA(X)
QUIT ""
+3 QUIT X
+4 ;
+5 ; Post Selection
Y(X) ; Set Y
+1 KILL Y
SET X=+($GET(X))
+2 if X'>0!('$DATA(^GMT(142,+X,0)))
SET Y=-1
if X'>0!('$DATA(^GMT(142,+X,0)))
QUIT
+3 SET Y=+X_"^"_$PIECE($GET(^GMT(142,+X,0)),"^",1)
+4 if $GET(GMTSDIC0)["Z"!($GET(DIC(0))["Z")
SET Y(0)=$GET(^GMT(142,+X,0))
SET Y(0,0)=$PIECE($GET(^GMT(142,+X,0)),"^",1)
SET Y(0,1)=$$MX(Y(0,0))
+5 IF +($GET(GMTSWY))=0
if $GET(GMTSDIC0)["E"!($GET(DIC(0))["E")
WRITE " ",$PIECE($GET(^GMT(142,+X,0)),"^",1)
SET GMTSWY=1
+6 if $GET(GMTSDIC0)'["F"&($GET(DIC(0))'["F")
DO SDISV
+7 QUIT
SDISV ; Save Default Value (Spacebar-Return)
+1 if $GET(GMTSDIC0)["F"
QUIT
if +($GET(DUZ))=0
QUIT
if '$LENGTH($$GET1^DIQ(200,(+($GET(DUZ))_","),.01))
QUIT
if +($GET(Y))=0
QUIT
if '$DATA(^GMT(142,+($GET(Y)),0))
QUIT
+2 DO RECALL^DILFD(142,+($GET(Y))_",",+($GET(DUZ)))
QUIT
+3 QUIT
MX(X) ; Mix Case
+1 QUIT $$EN^GMTSUMX(X)
