GMTSOBA2 ; SLC/KER - HS Object - Ask ; 05/22/2008
;;2.7;Health Summary;**58,89,106**;Oct 20, 1995;Build 11
;
; External References
; DBIA 10018 ^DIE (file #142)
; DBIA 10026 ^DIR
; DBIA 10006 ^DIC (file #142)
; DBIA 10010 EN1^DIP
; DBIA 10076 ^XUSEC(
; DBIA 10076 ^XUSEC("GMTSMGR")
;
CH ; Component Header
Q:+($G(GMTSQ))>0 N X,Y,DIR,DIROUT,DUOUT,DTOUT,GMTSDEF,GMTSE
S GMTSOBJ("COMPONENT HEADER")="",DIR("A")=" Print the standard Component Header? "
S GMTSDEF=$P($G(^GMT(142.5,+($G(GMTSDA)),0)),U,12),GMTSE=0
S GMTSDEF=$S(+GMTSDEF>0:"Y",GMTSDEF="":"Y",1:"N")
S DIR("B")=GMTSDEF,DIR(0)="YAO",(DIR("?"),DIR("??"))="^D CH^GMTSOBH"
D ^DIR S:$D(DIROUT)!($D(DTOUT)) GMTSQ=1
S:Y["^"!(X["^") GMTSE=1,GMTSQ=1,GMTSDES=0
K:+($G(GMTSQ))>0 GMTSOBJ("COMPONENT HEADER") Q:+($G(GMTSQ))>0
S X=+($G(Y)) K:+X'>0 GMTSOBJ("COMPONENT HEADER")
D:$D(GMTSOBJ("COMPONENT HEADER"))&(GMTSE'>0) LM Q:+($G(GMTSQ))>0 Q:+($G(GMTSE))>0
D:$D(GMTSOBJ("COMPONENT HEADER"))&(GMTSE'>0) UD Q:+($G(GMTSQ))>0 Q:+($G(GMTSE))>0
D:$D(GMTSOBJ("COMPONENT HEADER"))&(GMTSE'>0) BL Q:+($G(GMTSQ))>0 Q:+($G(GMTSE))>0
Q
LM ; Time/Occurence Limits
Q:+($G(GMTSQ))>0 Q:+($G(GMTSE))>0 N X,Y,DIR,DIROUT,DUOUT,DTOUT,GMTSDEF
S GMTSOBJ("LIMITS")="",DIR("A")=" Use report time/occurence limits? "
S GMTSDEF=$P($G(^GMT(142.5,+($G(GMTSDA)),0)),U,14)
S GMTSDEF=$S(+GMTSDEF>0:"Y",1:"N")
S (DIR("?"),DIR("??"))="^D LM^GMTSOBH",DIR("B")=GMTSDEF,DIR(0)="YAO"
D ^DIR S:$D(DIROUT)!($D(DTOUT)) GMTSE=1
S:Y["^"!(X["^") GMTSE=1,GMTSQ=1,GMTSDES=0
K:+($G(GMTSE))>0 GMTSOBJ("LIMITS") Q:+($G(GMTSE))>0
S X=+($G(Y)) K:+X'>0 GMTSOBJ("LIMITS") Q
UD ; Underline Header
Q:+($G(GMTSQ))>0 Q:+($G(GMTSE))>0
N X,Y,DIR,DIROUT,DUOUT,DTOUT,GMTSDEF
S GMTSOBJ("UNDERLINE")="",DIR("A")=" Underline Component Header? "
S GMTSDEF=$P($G(^GMT(142.5,+($G(GMTSDA)),0)),U,13)
S GMTSDEF=$S(+GMTSDEF>0:"Y",1:"N")
S (DIR("?"),DIR("??"))="^D CHU^GMTSOBH",DIR("B")=GMTSDEF,DIR(0)="YAO"
D ^DIR S:$D(DIROUT)!($D(DTOUT)) GMTSE=1
S:Y["^"!(X["^") GMTSE=1,GMTSQ=1,GMTSDES=0
K:+($G(GMTSE))>0 GMTSOBJ("UNDERLINE") Q:+($G(GMTSE))>0
S X=+($G(Y)) K:+X'>0 GMTSOBJ("UNDERLINE") Q
BL ; Blank Line after Header
Q:+($G(GMTSQ))>0 N X,Y,DIR,DIROUT,DUOUT,DTOUT,GMTSDEF
S GMTSOBJ("BLANK LINE")="",DIR("A")=" Add a Blank Line after the Component Header? "
S GMTSDEF=$P($G(^GMT(142.5,+($G(GMTSDA)),0)),U,15)
S GMTSDEF=$S(+GMTSDEF>0:"Y",1:"N")
S (DIR("?"),DIR("??"))="^D BL^GMTSOBH",DIR("B")=GMTSDEF,DIR(0)="YAO"
D ^DIR S:$D(DIROUT)!($D(DTOUT)) GMTSQ=1
K:+($G(GMTSQ))>0 GMTSOBJ("BLANK LINE") Q:+($G(GMTSQ))>0
S X=+($G(Y)) K:+X'>0 GMTSOBJ("BLANK LINE") Q
DE ; Deceased
Q:+($G(GMTSQ))>0 N X,Y,DIR,DIROUT,DUOUT,DTOUT,GMTSDEF
S GMTSOBJ("DECEASED")="",DIR("A")=" Print the date a patient was deceased? "
S GMTSDEF=$P($G(^GMT(142.5,+($G(GMTSDA)),0)),U,16)
S GMTSDEF=$S(+GMTSDEF>0:"Y",1:"N")
S (DIR("?"),DIR("??"))="^D DE^GMTSOBH",DIR("B")=GMTSDEF,DIR(0)="YAO"
D ^DIR S:$D(DIROUT)!($D(DTOUT)) GMTSQ=1
K:+($G(GMTSQ))>0 GMTSOBJ("DECEASED") Q:+($G(GMTSQ))>0
S X=+($G(Y)) K:+X'>0 GMTSOBJ("DECEASED") Q
LBL ; Label
Q:+($G(GMTSQ))>0 N X,Y,DIR,DIROUT,DUOUT,DTOUT,GMTSDLD,GMTSDEF
K GMTSOBJ("USE LABEL"),GMTSOBJ("LABEL"),GMTSOBJ("LABEL BLANK LINE")
S DIR("A")=" Print a LABEL before the Health Summary Object? "
S GMTSDEF=$S(+($G(GMTSDA))>0:$P($G(^GMT(142.5,+($G(GMTSDA)),0)),"^",7),1:0)
S GMTSDEF=$S(+GMTSDEF>0:"Y",1:"N"),(DIR("?"),DIR("??"))="^D PLB^GMTSOBH",DIR("B")=GMTSDEF,DIR(0)="YAO"
D ^DIR S:$D(DIROUT)!($D(DTOUT)) GMTSQ=1 S:Y["^"!(X["^") GMTSQ=1
K:+($G(GMTSQ))>0 GMTSOBJ("USE LABEL") Q:+($G(GMTSQ))>0
S GMTSOBJ("USE LABEL")=$S(+Y>0:1,1:0)
S X=+($G(Y)) D:+X LB Q
LB ; Object Label
Q:+($G(GMTSQ))>0 N X,Y,DIR,DIROUT,DUOUT,DTOUT,GMTSDEF,GMTSE
S GMTSOBJ("LABEL")="",DIR("A")=" Enter LABEL: "
S GMTSDEF=$P($G(^GMT(142.5,+($G(DA)),0)),"^",2) S:$L(GMTSDEF) DIR("B")=GMTSDEF
S (DIR("?"),DIR("??"))="^D LBH^GMTSOBH",DIR(0)="FAO^3:60"
D ^DIR S:$D(DIROUT)!($D(DTOUT)) GMTSE=1 S:Y["^"!(X["^") GMTSE=1
K:+($G(GMTSE))>0 GMTSOBJ("USE LABEL"),GMTSOBJ("LABEL"),GMTSOBJ("LABEL BLANK LINE")
Q:+($G(GMTSE))>0 S X=$G(Y) K:'$L(X) GMTSOBJ("USE LABEL"),GMTSOBJ("LABEL"),GMTSOBJ("LABEL BLANK LINE")
S:$L(X) GMTSOBJ("LABEL")=X_" " D:$L($G(GMTSOBJ("LABEL"))) LBB Q
LBB ; Label Blank Line
Q:+($G(GMTSE))>0 Q:+($G(GMTSQ))>0 N X,Y,DIR,DIROUT,DUOUT,DTOUT,GMTSDEF,GMTSE
S GMTSOBJ("LABEL BLANK LINE")="",DIR("A")=" Print a blank line after the Object Label? "
S GMTSDEF=$P($G(^GMT(142.5,+($G(DA)),0)),"^",8)
S GMTSDEF=$S(+GMTSDEF>0:"Y",1:"N") S DIR("B")=GMTSDEF
S (DIR("?"),DIR("??"))="^D LBLH^GMTSOBH",DIR(0)="YAO"
D ^DIR S:$D(DIROUT)!($D(DTOUT)) GMTSE=1 S:Y["^"!(X["^") GMTSE=1
K:+($G(GMTSE))>0 GMTSOBJ("LABEL BLANK LINE") Q:+($G(GMTSE))>0
S X=+($G(Y)) K:+X'>0 GMTSOBJ("LABEL BLANK LINE") Q
SC ; Suppress Components w/o Data
Q:+($G(GMTSQ))>0 N X,Y,DIR,DIROUT,DUOUT,DTOUT,GMTSDLD,GMTSDEF
S GMTSOBJ("SUPPRESS COMPONENTS")="",DIR("A")=" Suppress Components without Data? "
S GMTSDEF=$P($G(^GMT(142.5,+($G(GMTSDA)),0)),U,5)
S GMTSDEF=$S(+GMTSDEF>0:"Y",1:"N")
S (DIR("?"),DIR("??"))="^D SC^GMTSOBH",DIR("B")=GMTSDEF,DIR(0)="YAO"
D ^DIR S:$D(DIROUT)!($D(DTOUT)) GMTSQ=1
K:+($G(GMTSQ))>0 GMTSOBJ("SUPPRESS COMPONENTS") Q:+($G(GMTSQ))>0
S X=+($G(Y)) K:+X'>0 GMTSOBJ("SUPPRESS COMPONENTS")
Q
NODATA ; Override No Data Available output
Q:+($G(GMTSQ))>0 N X,Y,DIR,DIROUT,DUOUT,DTOUT,GMTSDLD,GMTSDEF
S GMTSOBJ("NO DATA")="",DIR("A")=" Overwrite No Data Available Message "
S GMTSDEF=$G(^GMT(142.5,+($G(GMTSDA)),2))
S (DIR("?"),DIR("??"))="^D NODATA^GMTSOBH",DIR("B")=GMTSDEF,DIR(0)="FO^3:60"
S DIR("PRE")="S:X[""^"" X=""^^""" ; p.106 stops error caused by user using "^TEXT" at prompt
D ^DIR S:$D(DIROUT)!($D(DTOUT)) GMTSQ=1
I +($G(GMTSQ))>0 S GMTSOBJ("NO DATA")="" Q
S GMTSOBJ("NO DATA")=$S(X="@":"@",1:Y) ; p.106 allows deletion of current field text
Q
;
ET(X) ; Edit Type X
Q:+($G(DUZ))'>0 N ADEL,B,BY,CHANGE,CNT,DA,DHD,DIC,DIE,DIK,DIR,DIROUT,DLAYGO,DR,DTOUT
N DUOUT,EXISTS,FLDS,FR,GMTSEG,GMTSIEN,GMTSDEF,GMTSIFN,GMTSMGR,GNTSN
N GMTSNEW,GMTSQIT,GMTSUM,GMTSV,GMTSAL,D,D0,D1,DQ,Y,L,LCNT,LI
N NXTCMP,SELCNT,SOACTION,TO,TWEENER S EXISTS=0,U="^",GMTSAL=1,GMTSQIT=0,X=$G(X) Q:'$L(X) Q:$L(X)>30
S DIC="^GMT(142,",DIC(0)="XMZ" K DLAYGO D ^DIC
S GMTSN=$P($G(^GMT(142,+Y,0)),"^",1) Q:'$L(GMTSN)
S GMTSUM=$P(Y,U,2) Q:'$L(GMTSUM) S:$D(DIROUT)!($D(DTOUT)) Y=-1 Q:+Y'>0
S GMTSNEW=+($P(Y,"^",3)),GMTSV=$$VTE^GMTSOBV(+Y) Q:+GMTSV'>0
S GMTSMGR=$S($D(^XUSEC("GMTSMGR",DUZ)):1,1:0)
S DIE="^GMT(142,",(GMTSIFN,DA)=+Y
S DR="[GMTS EDIT EXIST HS TYPE]"
W !!,"Editing Health Summary Type '",GMTSN,"'",!
D ^DIE
S EXISTS=0 S:($O(^GMT(142,+GMTSIFN,1,0))) EXISTS=1
D LIST:EXISTS,EXISTS
Q
EXISTS ; Edit an existing health summary type
N GMTSAL,CNT,NXTCMP Q:$D(DUOUT) S NXTCMP=0,NXTCMP(0)=0,GMTSAL=0
F CNT=$$GETCNT(GMTSIFN):0 D NXTCMP^GMTSRM1,LIST:GMTSQIT Q:GMTSQIT!($D(DUOUT)) K GMTSQIT,GMTSNEW,TWEENER,SOACTION
I NXTCMP>0 W !,"Please hold on while I resequence the summary order" D COPY^GMTSRN,RNMBR^GMTSRN:CHANGE
Q
LIST ; Lists existing summary parameters
N B,DIC,DIR,IOP,Y,FR,TO,BY,DHD,FLDS,L I GMTSQIT'=2 Q:($D(DUOUT)!(GMTSQIT=1))
I GMTSQIT=2,(NXTCMP=0) S GMTSQIT=0 Q
I 'GMTSNEW,'GMTSAL W ! S DIC=142,DIR(0)="Y",DIR("A")="Do you wish to review the Summary Type structure before continuing",DIR("B")="NO" D ^DIR K DIR I 'Y S:GMTSQIT=2 DUOUT="" S:GMTSQIT=2 GMTSQIT="D" S:$D(DUOUT) GMTSQIT=1 Q
I $D(GMTSQIT),GMTSQIT=2 S GMTSQIT=0
S IOP="HOME",DIC=142,(FR,TO)=GMTSUM,BY=".01",DHD="[GMTS TYPE INQ HEADER]-[GMTS TYPE INQ FOOTER]",FLDS="[GMTS TYPE INQ]",L=0 D EN1^DIP
Q
GETCNT(GMTSIFN) ; Determine default summary order for new component
N LI,LCNT S LI=0,LCNT=5 F S LI=$O(^GMT(142,+GMTSIFN,1,LI)) Q:+LI'>0 S LCNT=$P(LI,".")+5
Q LCNT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSOBA2 7943 printed Dec 13, 2024@01:58:18 Page 2
GMTSOBA2 ; SLC/KER - HS Object - Ask ; 05/22/2008
+1 ;;2.7;Health Summary;**58,89,106**;Oct 20, 1995;Build 11
+2 ;
+3 ; External References
+4 ; DBIA 10018 ^DIE (file #142)
+5 ; DBIA 10026 ^DIR
+6 ; DBIA 10006 ^DIC (file #142)
+7 ; DBIA 10010 EN1^DIP
+8 ; DBIA 10076 ^XUSEC(
+9 ; DBIA 10076 ^XUSEC("GMTSMGR")
+10 ;
CH ; Component Header
+1 if +($GET(GMTSQ))>0
QUIT
NEW X,Y,DIR,DIROUT,DUOUT,DTOUT,GMTSDEF,GMTSE
+2 SET GMTSOBJ("COMPONENT HEADER")=""
SET DIR("A")=" Print the standard Component Header? "
+3 SET GMTSDEF=$PIECE($GET(^GMT(142.5,+($GET(GMTSDA)),0)),U,12)
SET GMTSE=0
+4 SET GMTSDEF=$SELECT(+GMTSDEF>0:"Y",GMTSDEF="":"Y",1:"N")
+5 SET DIR("B")=GMTSDEF
SET DIR(0)="YAO"
SET (DIR("?"),DIR("??"))="^D CH^GMTSOBH"
+6 DO ^DIR
if $DATA(DIROUT)!($DATA(DTOUT))
SET GMTSQ=1
+7 if Y["^"!(X["^")
SET GMTSE=1
SET GMTSQ=1
SET GMTSDES=0
+8 if +($GET(GMTSQ))>0
KILL GMTSOBJ("COMPONENT HEADER")
if +($GET(GMTSQ))>0
QUIT
+9 SET X=+($GET(Y))
if +X'>0
KILL GMTSOBJ("COMPONENT HEADER")
+10 if $DATA(GMTSOBJ("COMPONENT HEADER"))&(GMTSE'>0)
DO LM
if +($GET(GMTSQ))>0
QUIT
if +($GET(GMTSE))>0
QUIT
+11 if $DATA(GMTSOBJ("COMPONENT HEADER"))&(GMTSE'>0)
DO UD
if +($GET(GMTSQ))>0
QUIT
if +($GET(GMTSE))>0
QUIT
+12 if $DATA(GMTSOBJ("COMPONENT HEADER"))&(GMTSE'>0)
DO BL
if +($GET(GMTSQ))>0
QUIT
if +($GET(GMTSE))>0
QUIT
+13 QUIT
LM ; Time/Occurence Limits
+1 if +($GET(GMTSQ))>0
QUIT
if +($GET(GMTSE))>0
QUIT
NEW X,Y,DIR,DIROUT,DUOUT,DTOUT,GMTSDEF
+2 SET GMTSOBJ("LIMITS")=""
SET DIR("A")=" Use report time/occurence limits? "
+3 SET GMTSDEF=$PIECE($GET(^GMT(142.5,+($GET(GMTSDA)),0)),U,14)
+4 SET GMTSDEF=$SELECT(+GMTSDEF>0:"Y",1:"N")
+5 SET (DIR("?"),DIR("??"))="^D LM^GMTSOBH"
SET DIR("B")=GMTSDEF
SET DIR(0)="YAO"
+6 DO ^DIR
if $DATA(DIROUT)!($DATA(DTOUT))
SET GMTSE=1
+7 if Y["^"!(X["^")
SET GMTSE=1
SET GMTSQ=1
SET GMTSDES=0
+8 if +($GET(GMTSE))>0
KILL GMTSOBJ("LIMITS")
if +($GET(GMTSE))>0
QUIT
+9 SET X=+($GET(Y))
if +X'>0
KILL GMTSOBJ("LIMITS")
QUIT
UD ; Underline Header
+1 if +($GET(GMTSQ))>0
QUIT
if +($GET(GMTSE))>0
QUIT
+2 NEW X,Y,DIR,DIROUT,DUOUT,DTOUT,GMTSDEF
+3 SET GMTSOBJ("UNDERLINE")=""
SET DIR("A")=" Underline Component Header? "
+4 SET GMTSDEF=$PIECE($GET(^GMT(142.5,+($GET(GMTSDA)),0)),U,13)
+5 SET GMTSDEF=$SELECT(+GMTSDEF>0:"Y",1:"N")
+6 SET (DIR("?"),DIR("??"))="^D CHU^GMTSOBH"
SET DIR("B")=GMTSDEF
SET DIR(0)="YAO"
+7 DO ^DIR
if $DATA(DIROUT)!($DATA(DTOUT))
SET GMTSE=1
+8 if Y["^"!(X["^")
SET GMTSE=1
SET GMTSQ=1
SET GMTSDES=0
+9 if +($GET(GMTSE))>0
KILL GMTSOBJ("UNDERLINE")
if +($GET(GMTSE))>0
QUIT
+10 SET X=+($GET(Y))
if +X'>0
KILL GMTSOBJ("UNDERLINE")
QUIT
BL ; Blank Line after Header
+1 if +($GET(GMTSQ))>0
QUIT
NEW X,Y,DIR,DIROUT,DUOUT,DTOUT,GMTSDEF
+2 SET GMTSOBJ("BLANK LINE")=""
SET DIR("A")=" Add a Blank Line after the Component Header? "
+3 SET GMTSDEF=$PIECE($GET(^GMT(142.5,+($GET(GMTSDA)),0)),U,15)
+4 SET GMTSDEF=$SELECT(+GMTSDEF>0:"Y",1:"N")
+5 SET (DIR("?"),DIR("??"))="^D BL^GMTSOBH"
SET DIR("B")=GMTSDEF
SET DIR(0)="YAO"
+6 DO ^DIR
if $DATA(DIROUT)!($DATA(DTOUT))
SET GMTSQ=1
+7 if +($GET(GMTSQ))>0
KILL GMTSOBJ("BLANK LINE")
if +($GET(GMTSQ))>0
QUIT
+8 SET X=+($GET(Y))
if +X'>0
KILL GMTSOBJ("BLANK LINE")
QUIT
DE ; Deceased
+1 if +($GET(GMTSQ))>0
QUIT
NEW X,Y,DIR,DIROUT,DUOUT,DTOUT,GMTSDEF
+2 SET GMTSOBJ("DECEASED")=""
SET DIR("A")=" Print the date a patient was deceased? "
+3 SET GMTSDEF=$PIECE($GET(^GMT(142.5,+($GET(GMTSDA)),0)),U,16)
+4 SET GMTSDEF=$SELECT(+GMTSDEF>0:"Y",1:"N")
+5 SET (DIR("?"),DIR("??"))="^D DE^GMTSOBH"
SET DIR("B")=GMTSDEF
SET DIR(0)="YAO"
+6 DO ^DIR
if $DATA(DIROUT)!($DATA(DTOUT))
SET GMTSQ=1
+7 if +($GET(GMTSQ))>0
KILL GMTSOBJ("DECEASED")
if +($GET(GMTSQ))>0
QUIT
+8 SET X=+($GET(Y))
if +X'>0
KILL GMTSOBJ("DECEASED")
QUIT
LBL ; Label
+1 if +($GET(GMTSQ))>0
QUIT
NEW X,Y,DIR,DIROUT,DUOUT,DTOUT,GMTSDLD,GMTSDEF
+2 KILL GMTSOBJ("USE LABEL"),GMTSOBJ("LABEL"),GMTSOBJ("LABEL BLANK LINE")
+3 SET DIR("A")=" Print a LABEL before the Health Summary Object? "
+4 SET GMTSDEF=$SELECT(+($GET(GMTSDA))>0:$PIECE($GET(^GMT(142.5,+($GET(GMTSDA)),0)),"^",7),1:0)
+5 SET GMTSDEF=$SELECT(+GMTSDEF>0:"Y",1:"N")
SET (DIR("?"),DIR("??"))="^D PLB^GMTSOBH"
SET DIR("B")=GMTSDEF
SET DIR(0)="YAO"
+6 DO ^DIR
if $DATA(DIROUT)!($DATA(DTOUT))
SET GMTSQ=1
if Y["^"!(X["^")
SET GMTSQ=1
+7 if +($GET(GMTSQ))>0
KILL GMTSOBJ("USE LABEL")
if +($GET(GMTSQ))>0
QUIT
+8 SET GMTSOBJ("USE LABEL")=$SELECT(+Y>0:1,1:0)
+9 SET X=+($GET(Y))
if +X
DO LB
QUIT
LB ; Object Label
+1 if +($GET(GMTSQ))>0
QUIT
NEW X,Y,DIR,DIROUT,DUOUT,DTOUT,GMTSDEF,GMTSE
+2 SET GMTSOBJ("LABEL")=""
SET DIR("A")=" Enter LABEL: "
+3 SET GMTSDEF=$PIECE($GET(^GMT(142.5,+($GET(DA)),0)),"^",2)
if $LENGTH(GMTSDEF)
SET DIR("B")=GMTSDEF
+4 SET (DIR("?"),DIR("??"))="^D LBH^GMTSOBH"
SET DIR(0)="FAO^3:60"
+5 DO ^DIR
if $DATA(DIROUT)!($DATA(DTOUT))
SET GMTSE=1
if Y["^"!(X["^")
SET GMTSE=1
+6 if +($GET(GMTSE))>0
KILL GMTSOBJ("USE LABEL"),GMTSOBJ("LABEL"),GMTSOBJ("LABEL BLANK LINE")
+7 if +($GET(GMTSE))>0
QUIT
SET X=$GET(Y)
if '$LENGTH(X)
KILL GMTSOBJ("USE LABEL"),GMTSOBJ("LABEL"),GMTSOBJ("LABEL BLANK LINE")
+8 if $LENGTH(X)
SET GMTSOBJ("LABEL")=X_" "
if $LENGTH($GET(GMTSOBJ("LABEL")))
DO LBB
QUIT
LBB ; Label Blank Line
+1 if +($GET(GMTSE))>0
QUIT
if +($GET(GMTSQ))>0
QUIT
NEW X,Y,DIR,DIROUT,DUOUT,DTOUT,GMTSDEF,GMTSE
+2 SET GMTSOBJ("LABEL BLANK LINE")=""
SET DIR("A")=" Print a blank line after the Object Label? "
+3 SET GMTSDEF=$PIECE($GET(^GMT(142.5,+($GET(DA)),0)),"^",8)
+4 SET GMTSDEF=$SELECT(+GMTSDEF>0:"Y",1:"N")
SET DIR("B")=GMTSDEF
+5 SET (DIR("?"),DIR("??"))="^D LBLH^GMTSOBH"
SET DIR(0)="YAO"
+6 DO ^DIR
if $DATA(DIROUT)!($DATA(DTOUT))
SET GMTSE=1
if Y["^"!(X["^")
SET GMTSE=1
+7 if +($GET(GMTSE))>0
KILL GMTSOBJ("LABEL BLANK LINE")
if +($GET(GMTSE))>0
QUIT
+8 SET X=+($GET(Y))
if +X'>0
KILL GMTSOBJ("LABEL BLANK LINE")
QUIT
SC ; Suppress Components w/o Data
+1 if +($GET(GMTSQ))>0
QUIT
NEW X,Y,DIR,DIROUT,DUOUT,DTOUT,GMTSDLD,GMTSDEF
+2 SET GMTSOBJ("SUPPRESS COMPONENTS")=""
SET DIR("A")=" Suppress Components without Data? "
+3 SET GMTSDEF=$PIECE($GET(^GMT(142.5,+($GET(GMTSDA)),0)),U,5)
+4 SET GMTSDEF=$SELECT(+GMTSDEF>0:"Y",1:"N")
+5 SET (DIR("?"),DIR("??"))="^D SC^GMTSOBH"
SET DIR("B")=GMTSDEF
SET DIR(0)="YAO"
+6 DO ^DIR
if $DATA(DIROUT)!($DATA(DTOUT))
SET GMTSQ=1
+7 if +($GET(GMTSQ))>0
KILL GMTSOBJ("SUPPRESS COMPONENTS")
if +($GET(GMTSQ))>0
QUIT
+8 SET X=+($GET(Y))
if +X'>0
KILL GMTSOBJ("SUPPRESS COMPONENTS")
+9 QUIT
NODATA ; Override No Data Available output
+1 if +($GET(GMTSQ))>0
QUIT
NEW X,Y,DIR,DIROUT,DUOUT,DTOUT,GMTSDLD,GMTSDEF
+2 SET GMTSOBJ("NO DATA")=""
SET DIR("A")=" Overwrite No Data Available Message "
+3 SET GMTSDEF=$GET(^GMT(142.5,+($GET(GMTSDA)),2))
+4 SET (DIR("?"),DIR("??"))="^D NODATA^GMTSOBH"
SET DIR("B")=GMTSDEF
SET DIR(0)="FO^3:60"
+5 ; p.106 stops error caused by user using "^TEXT" at prompt
SET DIR("PRE")="S:X[""^"" X=""^^"""
+6 DO ^DIR
if $DATA(DIROUT)!($DATA(DTOUT))
SET GMTSQ=1
+7 IF +($GET(GMTSQ))>0
SET GMTSOBJ("NO DATA")=""
QUIT
+8 ; p.106 allows deletion of current field text
SET GMTSOBJ("NO DATA")=$SELECT(X="@":"@",1:Y)
+9 QUIT
+10 ;
ET(X) ; Edit Type X
+1 if +($GET(DUZ))'>0
QUIT
NEW ADEL,B,BY,CHANGE,CNT,DA,DHD,DIC,DIE,DIK,DIR,DIROUT,DLAYGO,DR,DTOUT
+2 NEW DUOUT,EXISTS,FLDS,FR,GMTSEG,GMTSIEN,GMTSDEF,GMTSIFN,GMTSMGR,GNTSN
+3 NEW GMTSNEW,GMTSQIT,GMTSUM,GMTSV,GMTSAL,D,D0,D1,DQ,Y,L,LCNT,LI
+4 NEW NXTCMP,SELCNT,SOACTION,TO,TWEENER
SET EXISTS=0
SET U="^"
SET GMTSAL=1
SET GMTSQIT=0
SET X=$GET(X)
if '$LENGTH(X)
QUIT
if $LENGTH(X)>30
QUIT
+5 SET DIC="^GMT(142,"
SET DIC(0)="XMZ"
KILL DLAYGO
DO ^DIC
+6 SET GMTSN=$PIECE($GET(^GMT(142,+Y,0)),"^",1)
if '$LENGTH(GMTSN)
QUIT
+7 SET GMTSUM=$PIECE(Y,U,2)
if '$LENGTH(GMTSUM)
QUIT
if $DATA(DIROUT)!($DATA(DTOUT))
SET Y=-1
if +Y'>0
QUIT
+8 SET GMTSNEW=+($PIECE(Y,"^",3))
SET GMTSV=$$VTE^GMTSOBV(+Y)
if +GMTSV'>0
QUIT
+9 SET GMTSMGR=$SELECT($DATA(^XUSEC("GMTSMGR",DUZ)):1,1:0)
+10 SET DIE="^GMT(142,"
SET (GMTSIFN,DA)=+Y
+11 SET DR="[GMTS EDIT EXIST HS TYPE]"
+12 WRITE !!,"Editing Health Summary Type '",GMTSN,"'",!
+13 DO ^DIE
+14 SET EXISTS=0
if ($ORDER(^GMT(142,+GMTSIFN,1,0)))
SET EXISTS=1
+15 if EXISTS
DO LIST
DO EXISTS
+16 QUIT
EXISTS ; Edit an existing health summary type
+1 NEW GMTSAL,CNT,NXTCMP
if $DATA(DUOUT)
QUIT
SET NXTCMP=0
SET NXTCMP(0)=0
SET GMTSAL=0
+2 FOR CNT=$$GETCNT(GMTSIFN):0
DO NXTCMP^GMTSRM1
if GMTSQIT
DO LIST
if GMTSQIT!($DATA(DUOUT))
QUIT
KILL GMTSQIT,GMTSNEW,TWEENER,SOACTION
+3 IF NXTCMP>0
WRITE !,"Please hold on while I resequence the summary order"
DO COPY^GMTSRN
if CHANGE
DO RNMBR^GMTSRN
+4 QUIT
LIST ; Lists existing summary parameters
+1 NEW B,DIC,DIR,IOP,Y,FR,TO,BY,DHD,FLDS,L
IF GMTSQIT'=2
if ($DATA(DUOUT)!(GMTSQIT=1))
QUIT
+2 IF GMTSQIT=2
IF (NXTCMP=0)
SET GMTSQIT=0
QUIT
+3 IF 'GMTSNEW
IF 'GMTSAL
WRITE !
SET DIC=142
SET DIR(0)="Y"
SET DIR("A")="Do you wish to review the Summary Type structure before continuing"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
IF 'Y
if GMTSQIT=2
SET DUOUT=""
if GMTSQIT=2
SET GMTSQIT="D"
if $DATA(DUOUT)
SET GMTSQIT=1
QUIT
+4 IF $DATA(GMTSQIT)
IF GMTSQIT=2
SET GMTSQIT=0
+5 SET IOP="HOME"
SET DIC=142
SET (FR,TO)=GMTSUM
SET BY=".01"
SET DHD="[GMTS TYPE INQ HEADER]-[GMTS TYPE INQ FOOTER]"
SET FLDS="[GMTS TYPE INQ]"
SET L=0
DO EN1^DIP
+6 QUIT
GETCNT(GMTSIFN) ; Determine default summary order for new component
+1 NEW LI,LCNT
SET LI=0
SET LCNT=5
FOR
SET LI=$ORDER(^GMT(142,+GMTSIFN,1,LI))
if +LI'>0
QUIT
SET LCNT=$PIECE(LI,".")+5
+2 QUIT LCNT
