source: FOIAVistA/trunk/r/HEALTH_SUMMARY-GMTS/GMTSOBA2.m@ 642

Last change on this file since 642 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 7.0 KB
Line 
1GMTSOBA2 ; SLC/KER - HS Object - Ask ; 01/06/2003
2 ;;2.7;Health Summary;**58**;Oct 20, 1995
3 ;
4 ; External References
5 ; DBIA 10018 ^DIE (file #142)
6 ; DBIA 10026 ^DIR
7 ; DBIA 10006 ^DIC (file #142)
8 ; DBIA 10010 EN1^DIP
9 ; DBIA 10076 ^XUSEC(
10 ; DBIA 10076 ^XUSEC("GMTSMGR")
11 ;
12CH ; Component Header
13 Q:+($G(GMTSQ))>0 N X,Y,DIR,DIROUT,DUOUT,DTOUT,GMTSDEF,GMTSE
14 S GMTSOBJ("COMPONENT HEADER")="",DIR("A")=" Print the standard Component Header? "
15 S GMTSDEF=$P($G(^GMT(142.5,+($G(GMTSDA)),0)),U,12),GMTSE=0
16 S GMTSDEF=$S(+GMTSDEF>0:"Y",GMTSDEF="":"Y",1:"N")
17 S DIR("B")=GMTSDEF,DIR(0)="YAO",(DIR("?"),DIR("??"))="^D CH^GMTSOBH"
18 D ^DIR S:$D(DIROUT)!($D(DTOUT)) GMTSQ=1
19 S:Y["^"!(X["^") GMTSE=1,GMTSQ=1,GMTSDES=0
20 K:+($G(GMTSQ))>0 GMTSOBJ("COMPONENT HEADER") Q:+($G(GMTSQ))>0
21 S X=+($G(Y)) K:+X'>0 GMTSOBJ("COMPONENT HEADER")
22 D:$D(GMTSOBJ("COMPONENT HEADER"))&(GMTSE'>0) LM Q:+($G(GMTSQ))>0 Q:+($G(GMTSE))>0
23 D:$D(GMTSOBJ("COMPONENT HEADER"))&(GMTSE'>0) UD Q:+($G(GMTSQ))>0 Q:+($G(GMTSE))>0
24 D:$D(GMTSOBJ("COMPONENT HEADER"))&(GMTSE'>0) BL Q:+($G(GMTSQ))>0 Q:+($G(GMTSE))>0
25 Q
26LM ; Time/Occurence Limits
27 Q:+($G(GMTSQ))>0 Q:+($G(GMTSE))>0 N X,Y,DIR,DIROUT,DUOUT,DTOUT,GMTSDEF
28 S GMTSOBJ("LIMITS")="",DIR("A")=" Use report time/occurence limits? "
29 S GMTSDEF=$P($G(^GMT(142.5,+($G(GMTSDA)),0)),U,14)
30 S GMTSDEF=$S(+GMTSDEF>0:"Y",1:"N")
31 S (DIR("?"),DIR("??"))="^D LM^GMTSOBH",DIR("B")=GMTSDEF,DIR(0)="YAO"
32 D ^DIR S:$D(DIROUT)!($D(DTOUT)) GMTSE=1
33 S:Y["^"!(X["^") GMTSE=1,GMTSQ=1,GMTSDES=0
34 K:+($G(GMTSE))>0 GMTSOBJ("LIMITS") Q:+($G(GMTSE))>0
35 S X=+($G(Y)) K:+X'>0 GMTSOBJ("LIMITS") Q
36UD ; Underline Header
37 Q:+($G(GMTSQ))>0 Q:+($G(GMTSE))>0
38 N X,Y,DIR,DIROUT,DUOUT,DTOUT,GMTSDEF
39 S GMTSOBJ("UNDERLINE")="",DIR("A")=" Underline Component Header? "
40 S GMTSDEF=$P($G(^GMT(142.5,+($G(GMTSDA)),0)),U,13)
41 S GMTSDEF=$S(+GMTSDEF>0:"Y",1:"N")
42 S (DIR("?"),DIR("??"))="^D CHU^GMTSOBH",DIR("B")=GMTSDEF,DIR(0)="YAO"
43 D ^DIR S:$D(DIROUT)!($D(DTOUT)) GMTSE=1
44 S:Y["^"!(X["^") GMTSE=1,GMTSQ=1,GMTSDES=0
45 K:+($G(GMTSE))>0 GMTSOBJ("UNDERLINE") Q:+($G(GMTSE))>0
46 S X=+($G(Y)) K:+X'>0 GMTSOBJ("UNDERLINE") Q
47BL ; Blank Line after Header
48 Q:+($G(GMTSQ))>0 N X,Y,DIR,DIROUT,DUOUT,DTOUT,GMTSDEF
49 S GMTSOBJ("BLANK LINE")="",DIR("A")=" Add a Blank Line after the Component Header? "
50 S GMTSDEF=$P($G(^GMT(142.5,+($G(GMTSDA)),0)),U,15)
51 S GMTSDEF=$S(+GMTSDEF>0:"Y",1:"N")
52 S (DIR("?"),DIR("??"))="^D BL^GMTSOBH",DIR("B")=GMTSDEF,DIR(0)="YAO"
53 D ^DIR S:$D(DIROUT)!($D(DTOUT)) GMTSQ=1
54 K:+($G(GMTSQ))>0 GMTSOBJ("BLANK LINE") Q:+($G(GMTSQ))>0
55 S X=+($G(Y)) K:+X'>0 GMTSOBJ("BLANK LINE") Q
56DE ; Deceased
57 Q:+($G(GMTSQ))>0 N X,Y,DIR,DIROUT,DUOUT,DTOUT,GMTSDEF
58 S GMTSOBJ("DECEASED")="",DIR("A")=" Print the date a patient was deceased? "
59 S GMTSDEF=$P($G(^GMT(142.5,+($G(GMTSDA)),0)),U,16)
60 S GMTSDEF=$S(+GMTSDEF>0:"Y",1:"N")
61 S (DIR("?"),DIR("??"))="^D DE^GMTSOBH",DIR("B")=GMTSDEF,DIR(0)="YAO"
62 D ^DIR S:$D(DIROUT)!($D(DTOUT)) GMTSQ=1
63 K:+($G(GMTSQ))>0 GMTSOBJ("DECEASED") Q:+($G(GMTSQ))>0
64 S X=+($G(Y)) K:+X'>0 GMTSOBJ("DECEASED") Q
65LBL ; Label
66 Q:+($G(GMTSQ))>0 N X,Y,DIR,DIROUT,DUOUT,DTOUT,GMTSDLD,GMTSDEF
67 K GMTSOBJ("USE LABEL"),GMTSOBJ("LABEL"),GMTSOBJ("LABEL BLANK LINE")
68 S DIR("A")=" Print a LABEL before the Health Summary Object? "
69 S GMTSDEF=$S(+($G(GMTSDA))>0:$P($G(^GMT(142.5,+($G(GMTSDA)),0)),"^",7),1:0)
70 S GMTSDEF=$S(+GMTSDEF>0:"Y",1:"N"),(DIR("?"),DIR("??"))="^D PLB^GMTSOBH",DIR("B")=GMTSDEF,DIR(0)="YAO"
71 D ^DIR S:$D(DIROUT)!($D(DTOUT)) GMTSQ=1 S:Y["^"!(X["^") GMTSQ=1
72 K:+($G(GMTSQ))>0 GMTSOBJ("USE LABEL") Q:+($G(GMTSQ))>0
73 S GMTSOBJ("USE LABEL")=$S(+Y>0:1,1:0)
74 S X=+($G(Y)) D:+X LB Q
75LB ; Object Label
76 Q:+($G(GMTSQ))>0 N X,Y,DIR,DIROUT,DUOUT,DTOUT,GMTSDEF,GMTSE
77 S GMTSOBJ("LABEL")="",DIR("A")=" Enter LABEL: "
78 S GMTSDEF=$P($G(^GMT(142.5,+($G(DA)),0)),"^",2) S:$L(GMTSDEF) DIR("B")=GMTSDEF
79 S (DIR("?"),DIR("??"))="^D LBH^GMTSOBH",DIR(0)="FAO^3:60"
80 D ^DIR S:$D(DIROUT)!($D(DTOUT)) GMTSE=1 S:Y["^"!(X["^") GMTSE=1
81 K:+($G(GMTSE))>0 GMTSOBJ("USE LABEL"),GMTSOBJ("LABEL"),GMTSOBJ("LABEL BLANK LINE")
82 Q:+($G(GMTSE))>0 S X=$G(Y) K:'$L(X) GMTSOBJ("USE LABEL"),GMTSOBJ("LABEL"),GMTSOBJ("LABEL BLANK LINE")
83 S:$L(X) GMTSOBJ("LABEL")=X_" " D:$L($G(GMTSOBJ("LABEL"))) LBB Q
84LBB ; Label Blank Line
85 Q:+($G(GMTSE))>0 Q:+($G(GMTSQ))>0 N X,Y,DIR,DIROUT,DUOUT,DTOUT,GMTSDEF,GMTSE
86 S GMTSOBJ("LABEL BLANK LINE")="",DIR("A")=" Print a blank line after the Object Label? "
87 S GMTSDEF=$P($G(^GMT(142.5,+($G(DA)),0)),"^",8)
88 S GMTSDEF=$S(+GMTSDEF>0:"Y",1:"N") S DIR("B")=GMTSDEF
89 S (DIR("?"),DIR("??"))="^D LBLH^GMTSOBH",DIR(0)="YAO"
90 D ^DIR S:$D(DIROUT)!($D(DTOUT)) GMTSE=1 S:Y["^"!(X["^") GMTSE=1
91 K:+($G(GMTSE))>0 GMTSOBJ("LABEL BLANK LINE") Q:+($G(GMTSE))>0
92 S X=+($G(Y)) K:+X'>0 GMTSOBJ("LABEL BLANK LINE") Q
93SC ; Suppress Components w/o Data
94 Q:+($G(GMTSQ))>0 N X,Y,DIR,DIROUT,DUOUT,DTOUT,GMTSDLD,GMTSDEF
95 S GMTSOBJ("SUPPRESS COMPONENTS")="",DIR("A")=" Suppress Components without Data? "
96 S GMTSDEF=$P($G(^GMT(142.5,+($G(GMTSDA)),0)),U,5)
97 S GMTSDEF=$S(+GMTSDEF>0:"Y",1:"N")
98 S (DIR("?"),DIR("??"))="^D SC^GMTSOBH",DIR("B")=GMTSDEF,DIR(0)="YAO"
99 D ^DIR S:$D(DIROUT)!($D(DTOUT)) GMTSQ=1
100 K:+($G(GMTSQ))>0 GMTSOBJ("SUPPRESS COMPONENTS") Q:+($G(GMTSQ))>0
101 S X=+($G(Y)) K:+X'>0 GMTSOBJ("SUPPRESS COMPONENTS")
102 Q
103ET(X) ; Edit Type X
104 Q:+($G(DUZ))'>0 N ADEL,B,BY,CHANGE,CNT,DA,DHD,DIC,DIE,DIK,DIR,DIROUT,DLAYGO,DR,DTOUT
105 N DUOUT,EXISTS,FLDS,FR,GMTSEG,GMTSIEN,GMTSDEF,GMTSIFN,GMTSMGR,GNTSN
106 N GMTSNEW,GMTSQIT,GMTSUM,GMTSV,GMTSAL,D,D0,D1,DQ,Y,L,LCNT,LI
107 N NXTCMP,SELCNT,SOACTION,TO,TWEENER S EXISTS=0,U="^",GMTSAL=1,GMTSQIT=0,X=$G(X) Q:'$L(X) Q:$L(X)>30
108 S DIC="^GMT(142,",DIC(0)="XMZ" K DLAYGO D ^DIC
109 S GMTSN=$P($G(^GMT(142,+Y,0)),"^",1) Q:'$L(GMTSN)
110 S GMTSUM=$P(Y,U,2) Q:'$L(GMTSUM) S:$D(DIROUT)!($D(DTOUT)) Y=-1 Q:+Y'>0
111 S GMTSNEW=+($P(Y,"^",3)),GMTSV=$$VTE^GMTSOBV(+Y) Q:+GMTSV'>0
112 S GMTSMGR=$S($D(^XUSEC("GMTSMGR",DUZ)):1,1:0)
113 S DIE="^GMT(142,",(GMTSIFN,DA)=+Y
114 S DR="[GMTS EDIT EXIST HS TYPE]"
115 W !!,"Editing Health Summary Type '",GMTSN,"'",!
116 D ^DIE
117 S EXISTS=0 S:($O(^GMT(142,+GMTSIFN,1,0))) EXISTS=1
118 D LIST:EXISTS,EXISTS
119 Q
120EXISTS ; Edit an existing health summary type
121 N GMTSAL,CNT,NXTCMP Q:$D(DUOUT) S NXTCMP=0,NXTCMP(0)=0,GMTSAL=0
122 F CNT=$$GETCNT(GMTSIFN):0 D NXTCMP^GMTSRM1,LIST:GMTSQIT Q:GMTSQIT!($D(DUOUT)) K GMTSQIT,GMTSNEW,TWEENER,SOACTION
123 I NXTCMP>0 W !,"Please hold on while I resequence the summary order" D COPY^GMTSRN,RNMBR^GMTSRN:CHANGE
124 Q
125LIST ; Lists existing summary parameters
126 N B,DIC,DIR,IOP,Y,FR,TO,BY,DHD,FLDS,L I GMTSQIT'=2 Q:($D(DUOUT)!(GMTSQIT=1))
127 I GMTSQIT=2,(NXTCMP=0) S GMTSQIT=0 Q
128 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
129 I $D(GMTSQIT),GMTSQIT=2 S GMTSQIT=0
130 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
131 Q
132GETCNT(GMTSIFN) ; Determine default summary order for new component
133 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
134 Q LCNT
Note: See TracBrowser for help on using the repository browser.