- 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 Feb 18, 2025@23:26:55 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)