Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: GMTSULT6

GMTSULT6.m

Go to the documentation of this file.
  1. GMTSULT6 ; SLC/KER - HS Type Lookup (Select) ; 08/27/2002
  1. ;;2.7;Health Summary;**30,32,56**;Oct 20, 1995
  1. ;
  1. ; External References
  1. ; DBIA 10026 ^DIR
  1. ; DBIA 10006 ^DIC (file #142)
  1. ; DBIA 10060 ^VA(200,
  1. ; DBIA 2056 $$GET1^DIQ (file #200)
  1. ; DBIA 10016 ^DIM
  1. ; DBIA 2055 RECALL^DILFD
  1. Q
  1. ;
  1. MULTI ; Selection when Multiple Entries are found
  1. I $L($G(GMTSDICB)),GMTSDEF=1 D DEF Q
  1. S GMTSDICW=$$DICW($G(GMTSDICW)) K:'$L(GMTSDICW) GMTSDICW
  1. N GMTSIEN,GMTSE,GMTSO,GMTST,GMTSTOT,GMTSM S GMTSTOT=^TMP("GMTSULT",$J,0) Q:+GMTSTOT=0 I +GMTSTOT=1 D ONE Q
  1. W ! W:+GMTSTOT>1 !,GMTSTOT," Health Summary Types found"
  1. N GMTSI,GMTSS,GMTSEX,X,GMTSTR,GMTSTR2,GMTSTR3,GMTSLEN S GMTSLEN=75,GMTSS=0,GMTSEX=0
  1. ; List 5 at a time
  1. F GMTSI=1:1:^TMP("GMTSULT",$J,0) Q:((GMTSS>0)&(GMTSS<GMTSI+1)) Q:GMTSEX D Q:GMTSEX
  1. . S GMTSE=$G(^TMP("GMTSULT",$J,GMTSI))
  1. . S GMTSM=GMTSI W:GMTSI#5=1 ! W !,$J(GMTSI,4),". "
  1. . S GMTSIEN=+GMTSE,(GMTST,GMTSTR)=$P(GMTSE,U,7),GMTSO=$P(GMTSE,U,2)
  1. . S:'$L(GMTSTR)&($L(GMTSO)) GMTSTR=GMTSO
  1. . D WRM1
  1. . W:GMTSI#5=0 ! S:GMTSI#5=0 GMTSS=$$SEL(GMTSM) S:GMTSS["^" GMTSEX=1
  1. I GMTSI#5'=0,+GMTSS=0 W ! S GMTSS=$$SEL(GMTSM) S:GMTSS["^" GMTSEX=1
  1. I 'GMTSEX,+GMTSS>0 D Q
  1. . N GMTSNAM K Y S Y=+($G(^TMP("GMTSULT",$J,+GMTSS)))
  1. . S GMTSNAM=$P($G(^GMT(142,+Y,0)),"^",1) I '$L(GMTSNAM) K Y S Y=-1 Q
  1. . D Y(+Y)
  1. K Y S Y=-1
  1. Q
  1. WRM1 ; Write one entry of muli selection
  1. N Y,GMTS S Y=+GMTSIEN,GMTS=$G(^GMT(142,+Y,0))
  1. I '$D(GMTSDICW) W:$L(GMTSTR)'>GMTSLEN GMTSTR D:$L(GMTSTR)>GMTSLEN LONG Q
  1. I $D(GMTSDICW),$G(GMTSDIC0)'["S" W $P(GMTS,"^",1)," " X GMTSDICW Q
  1. I $D(GMTSDICW),$G(GMTSDIC0)["S" X GMTSDICW Q
  1. Q
  1. SEL(X) ; Select multiple
  1. N Y,GMTSM,DTOUT,DUOUT,DIRUT,DIROUT S GMTSM=+($G(X)) Q:GMTSM=0 -1
  1. S:+($O(^TMP("GMTSULT",$J,+($G(GMTSI)))))>0 DIR("A")="Press <RETURN> for more, '^' to exit, or Select 1-"_GMTSM_": "
  1. S:+($O(^TMP("GMTSULT",$J,+($G(GMTSI)))))'>0 DIR("A")="Select 1-"_GMTSM_": "
  1. S (DIR("?"),DIR("??"))="Answer must be from 1 to "_GMTSM_", or <Return> to continue "
  1. S DIR(0)="NAO^1:"_GMTSM_":0" D ^DIR S:$D(DTOUT)!(X[U) X=U K DIR Q X
  1. Q
  1. ;
  1. ONE ; One entry on the selection list
  1. I $L($G(GMTSDICB)),GMTSDEF=1 D DEF Q
  1. N GMTSEX,GMTSIEN,GMTSTR,GMTSTR2,GMTSY,GMTSX,GMTSLEN,DIR,X
  1. S GMTSLEN=75,Y=0 S:GMTSQ!($G(GMTSDIC0)["E") GMTSQ=1,Y=1
  1. S GMTSEX=0
  1. ; No Echo or if Ask
  1. S GMTSIEN=+($G(^TMP("GMTSULT",$J,1)))
  1. I 'GMTSQ!($G(GMTSDIC0)["A") D
  1. . N X S GMTSTR=$P($G(^TMP("GMTSULT",$J,1)),U,7)
  1. . S:'$L(GMTSTR) GMTSTR=$P($G(^TMP("GMTSULT",$J,1)),U,2)
  1. . D WRO1 S Y=$$OK S:Y["^" GMTSEX=1
  1. I 'GMTSEX,+Y>0 D Q
  1. . N GMTSNAM K Y S Y=+($G(^TMP("GMTSULT",$J,1)))
  1. . S GMTSNAM=$P($G(^GMT(142,+Y,0)),"^",1) I '$L(GMTSNAM) K Y S Y=-1 Q
  1. . D Y(+Y)
  1. K Y S Y=-1
  1. Q
  1. WRO1 ; Write one entry of single selection
  1. W !!," " N Y,GMTS S Y=+GMTSIEN,GMTS=$G(^GMT(142,+Y,0))
  1. I '$D(GMTSDICW) W:$L(GMTSTR)'>GMTSLEN GMTSTR D:$L(GMTSTR)>GMTSLEN LONG W ! Q
  1. I $D(GMTSDICW),$G(GMTSDIC0)'["S" W $P(GMTS,"^",1)," " X GMTSDICW W ! Q
  1. I $D(GMTSDICW),$G(GMTSDIC0)["S" X GMTSDICW W ! Q
  1. Q
  1. OK(X) ; Select one if DIC(0)["A" Ask OK
  1. N DIR,DTOUT,DUOUT,DIROUT S DIR(0)="YAO",DIR("B")="YES"
  1. S DIR("A")=" OK? " D ^DIR S:X'["^" X=+Y S:$D(DTOUT)!($D(DUOUT)) X="^" S:X["^" X="^" Q X
  1. ;
  1. DEF ; Select Default Entry
  1. N GMTSNAM K Y S Y=+($G(^TMP("GMTSULT",$J,1)))
  1. S GMTSNAM=$P($G(^GMT(142,+Y,0)),"^",1) I '$L(GMTSNAM) K Y S Y=-1 Q
  1. D Y(+Y)
  1. Q
  1. ;
  1. ; Display
  1. LONG ; Handle a long string
  1. N GMTSP,GMTSOK,GMTSCHR,GMTSPSN,GMTSTO,GMTSREM,GMTSLN,GMTSOLD S GMTSLN=0,GMTSOLD=GMTSTR,GMTSP=5
  1. F Q:$L(GMTSTR)<(GMTSLEN+1) D PARSE Q:$L(GMTSTR)<(GMTSLEN+1)
  1. S GMTSLN=GMTSLN+1 W:GMTSLN>1 ! W ?GMTSP,GMTSTR
  1. Q
  1. PARSE ; Parse a long string to screen length
  1. S GMTSOK=0,GMTSCHR="" F GMTSPSN=GMTSLEN:-1:0 Q:+GMTSOK=1 D Q:+GMTSOK=1
  1. . I $E(GMTSTR,GMTSPSN)=" " S GMTSCHR=" ",GMTSOK=1 Q
  1. . I $E(GMTSTR,GMTSPSN)="," S GMTSCHR=",",GMTSOK=1 Q
  1. . I $E(GMTSTR,GMTSPSN)="/" S GMTSCHR="/",GMTSOK=1 Q
  1. . I $E(GMTSTR,GMTSPSN)="-" S GMTSCHR="-",GMTSOK=1 Q
  1. I GMTSCHR=" " S GMTSTO=$E(GMTSTR,1,GMTSPSN-1),GMTSREM=$E(GMTSTR,GMTSPSN+1,$L(GMTSTR))
  1. 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))
  1. 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))
  1. 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))
  1. S GMTSTR=GMTSREM,GMTSLN=GMTSLN+1 W:GMTSLN>1 ! W ?GMTSP,GMTSTO
  1. Q
  1. DICW(X) ; Check for valid DIC("W")
  1. S X=$G(X) Q:'$L(X) ""
  1. D ^DIM I '$D(X) Q ""
  1. Q X
  1. ;
  1. ; Post Selection
  1. Y(X) ; Set Y
  1. K Y S X=+($G(X))
  1. S:X'>0!('$D(^GMT(142,+X,0))) Y=-1 Q:X'>0!('$D(^GMT(142,+X,0)))
  1. S Y=+X_"^"_$P($G(^GMT(142,+X,0)),"^",1)
  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))
  1. I +($G(GMTSWY))=0 W:$G(GMTSDIC0)["E"!($G(DIC(0))["E") " ",$P($G(^GMT(142,+X,0)),"^",1) S GMTSWY=1
  1. D:$G(GMTSDIC0)'["F"&($G(DIC(0))'["F") SDISV
  1. Q
  1. SDISV ; Save Default Value (Spacebar-Return)
  1. 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))
  1. D RECALL^DILFD(142,+($G(Y))_",",+($G(DUZ))) Q
  1. Q
  1. MX(X) ; Mix Case
  1. Q $$EN^GMTSUMX(X)