source: FOIAVistA/tag/r/HEALTH_SUMMARY-GMTS/GMTSOBL.m@ 628

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

initial load of FOIAVistA 6/30/08 version
File size: 8.7 KB
Line 
1GMTSOBL ; SLC/KER - HS Object - Lookup ; 01/06/2003
2 ;;2.7;Health Summary;**58**;Oct 20, 1995
3 ;
4 ; External References
5 ; DBIA 10006 ^DIC (file #142.5)
6 ; DBIA 10018 ^DIE (file #142 and 142.5)
7 ; DBIA 10013 ^DIK (file #142 and 142.5)
8 ; DBIA 10026 ^DIR
9 ; DBIA 10010 EN1^DIP
10 ; DBIA 10076 ^XUSEC(
11 ; DBIA 10076 ^XUSEC("GMTSMGR")
12 ; DBIA 10112 $$SITE^VASITE
13 ; DBIA 10103 $$NOW^XLFDT
14 ;
15 Q
16OBJ(X) ; Lookup HS Object
17 Q:+($G(DUZ))'>0 -1 N DIR,DIC,DTOUT,DUOUT,DIROUT,DLAYGO,DA,D,D0,D1,DI,DQ,Y S U="^"
18 S DIC="^GMT(142.5,",DIC(0)="AEMQ",DIC("A")=" Select HEALTH SUMMARY OBJECT: " K DLAYGO D ^DIC
19 S:+($$ABT)>0 Y=-1 S X=+($G(Y))
20 Q X
21HSO(X) ; Lookup HS Object (by Known Name)
22 I +($G(DUZ))'>0 S GMTSQ=1 Q -1
23 N GMTSOWN,GMTSDICS,GMTSNAM,GMTSIEN,GMTSNEW
24 N DIR,DIC,DTOUT,DUOUT,DIROUT,DLAYGO,DINUM,DA,D,D0,D1,DI,DQ,Y,GMTSL,GMTSH,GMTSS,GMTSTA S U="^"
25 S GMTSNAM=$G(X),GMTSNEW=0,GMTSOWN="",GMTSQ=0 I '$L(GMTSNAM) S GMTSQ=1 Q -1
26 S X=GMTSNAM I '$L(X) S X=-1,GMTSQ=1 Q X
27 S DIC="^GMT(142.5,",DIC(0)="XML",DLAYGO=142.5 S:$L($G(GMTSDICS)) DIC("S")=$G(GMTSDICS)
28 S GMTSTA=+($P($$SITE^VASITE,"^",3)) I +GMTSTA'>0 S X=-1,GMTSQ=1 Q X
29 S GMTSS=+($G(GMTSTA)) S:$D(GMTSDEV) GMTSS=5000 S GMTSL=GMTSS_"0000"
30 S GMTSH=GMTSS_"9999" S GMTSH=($O(^GMT(142.5,+GMTSH),-1)+1)
31 S:+GMTSH<+GMTSL GMTSH=+GMTSS_"0001" S:+GMTSH>0 DINUM=+GMTSH
32 D ^DIC I +($$ABT)>0 S GMTSQ=1,X=-1 Q X
33 S GMTSNEW=+($P(Y,"^",3))
34 I +Y'>0 S X=-1 Q X
35 S X=+($G(Y))_"^"_$P($G(^GMT(142.5,+($G(Y)),0)),"^",1) S:+GMTSNEW>0 $P(X,"^",3)=+GMTSNEW
36 W:GMTSNEW>0 !,"Creating Health Summary Object '",GMTSNAM,"'"
37 S:+GMTSNEW>0 X=$$EE(Y) I +($G(GMTSQ))>1 S X=-1 Q
38 S:+X'>0 X=-1 I +($G(GMTSQ))=0 D
39 . D:+GMTSNEW>0&(+X>0) NEW^GMTSOBL2(+X)
40 . D:+GMTSNEW'>0&(+X>0) MOD^GMTSOBL2(+X)
41 Q X
42LK(X) ; Lookup HS Object (Learn as you go)
43 Q:+($G(DUZ))'>0 -1 N GMTSDICS,GMTSB S GMTSDICS=$G(DIC("S")) K DIC("S") S GMTSDICS=$$DIM^GMTSOBL2(GMTSDICS),GMTSB=$P($$B^GMTSOBL2,"^",2)
44 N DIR,DIC,DTOUT,DUOUT,DIROUT,DLAYGO,DA,D,D0,D1,DI,DQ,GMTSNAM,GMTSTA
45 N GMTS,GMTSTD,GMTSOBJ,GMTSOBN,GMTSDT,GMTSNEW,GMTSDEF,GMTSDA,Y,X1 S U="^"
46 S GMTSNEW=0,GMTSTA=+($P($$SITE^VASITE,"^",3)) Q:+GMTSTA=0 -1
47 S DIR(0)="FAO^1:30^S:X="" "" (X,X1)=$G(GMTSB) K:$L(X)<3&(X'="" "") X"
48 S DIR("A")=" Select HEALTH SUMMARY OBJECT: ",(DIR("?"),DIR("??"))="^D NAH^GMTSOBL2"
49 D ^DIR Q:'$L(Y)!(Y["^") -1 S GMTSNAM=Y
50 S DIC="^GMT(142.5,",DIC(0)="EM" S:$L($G(GMTSDICS)) DIC("S")=$G(GMTSDICS)
51 W ! D ^DIC
52 I +($$ABT)>0 S GMTSQ=1,Y=-1,X=-1 Q X
53 I +Y'>0 D Q:+Y'>0 -1
54 . N X,DIC,DINUM,GMTSL,GMTSH,GMTSS S GMTSS=+($G(GMTSTA)) S:$D(GMTSDEV) GMTSS=5000
55 . S X=$G(GMTSNAM) Q:'$L(X) S GMTSL=GMTSS_"0000"
56 . S GMTSH=GMTSS_"9999",GMTSH=($O(^GMT(142.5,+GMTSH),-1)+1)
57 . S:+GMTSH<+GMTSL GMTSH=+GMTSS_"0001" S:+GMTSH>0 DINUM=+GMTSH
58 . S DIC="^GMT(142.5,",DIC(0)="EML",DLAYGO=142.5
59 . S:$L($G(GMTSDICS)) DIC("S")=$G(GMTSDICS) D ^DIC
60 . S GMTSNEW=+($P(Y,"^",3))
61 . I +($$ABT)>0 S GMTSQ=1
62 I +($G(GMTSQ))>0 S Y=-1,X=-1 Q X
63 S X=+($G(Y))_"^"_$P($G(^GMT(142.5,+($G(Y)),0)),"^",1)
64 S:+GMTSNEW>0 $P(X,"^",3)=+GMTSNEW S X=$$EE(Y) S:+X'>0 X=-1 I +X'>0 S GMTSQ=1,Y=-1,X=-1 Q X
65 I +($G(GMTSQ))=0 D:+GMTSNEW>0&(+X>0) NEW^GMTSOBL2(+X) D:+GMTSNEW'>0&(+X>0) MOD^GMTSOBL2(+X)
66 Q X
67EE(X) ; Enter/Edit
68 N GMTSOBJ,DA,GMTSY,GMTSNAM,GMTSTYP,GMTSDICS,GMTSDICA,GMTSDICB,Y S Y=$G(X) S (GMTSOBJ,DA,X)=+($G(Y)),GMTSY=$G(Y)
69 S GMTSTYP=$P($G(^GMT(142.5,+DA,0)),"^",3),GMTSTYP=$P($G(^GMT(142,+GMTSTYP,0)),"^",1)
70 S GMTSNEW=$S(+($P($G(Y),U,3))>0:1,1:0) I GMTSNEW>0 D
71 . S $P(^GMT(142.5,+DA,0),"^",20)=$S($D(GMTSDEV):1,1:0)
72 S GMTSDT=$$NOW^XLFDT,GMTSOBN=$P($G(^GMT(142.5,+X,0)),U,1)
73 I $D(GMTSOWN) D I X'>0 S GMTSQ=1 Q X
74 . N GMTSCRE S GMTSCRE=$P($G(^GMT(142.5,+X,0)),"^",17) Q:+GMTSCRE'>0
75 . I GMTSNEW'>0,GMTSCRE'=DUZ W !!," Sorry, you can not edit someone else's object." S X=-1
76 I GMTSNEW>0,+DA>0,$D(^GMT(142.5,+DA,0)) D
77 . S $P(^GMT(142.5,+DA,0),U,17)=+($G(DUZ)),$P(^GMT(142.5,+DA,0),U,18)=+GMTSDT
78 I +X>0 D Q:$G(X)=-1!($G(DA)=-1)!($G(Y)=-1) -1
79 . N DIR,DIC,DTOUT,DUOUT,DIROUT,DLAYGO,X,Y,GMTSDEF,GMTSD,GMTSDA
80 . S GMTSDA=+DA,GMTSD=""
81 . ; Type
82 . S GMTSDEF=$P($G(^GMT(142.5,+DA,0)),U,3),GMTSD=$P($G(^GMT(142,+GMTSDEF,0)),"^",1)
83 . S:$L(GMTSD) DIC("B")=GMTSDEF S DIC("A")=" Select HEALTH SUMMARY TYPE: "
84 . S:$D(GMTSDEV) DIC("S")="I +($G(^GMT(142,+Y,""VA"")))>0"
85 . D K S GMTS=$$TY(GMTSDEF)
86 . I +($$ABT)>0 D Q
87 . . W !,"<<<<<< ABORT >>>>>>"
88 . . S GMTSQ=1,X=-1 I +($G(GMTSNEW))>0 S DIK="^GMT(142.5,",DA=GMTSDA D ^DIK
89 . I $G(X)="@" S GMTSQ=1 S:$L(GMTSDEF) GMTS=GMTSD_"^"_GMTSDEF D NT^GMTSOBL2(GMTSY) Q
90 . I +GMTS'>0,+DA>0,GMTSNEW>0 S GMTSQ=1 D NT^GMTSOBL2(GMTSY) Q
91 . I +GMTS>0,+DA>0 D Q:$G(X)=-1!($G(DA)=-1)!($G(Y)=-1) Q:+($G(GMTSQ))>0
92 . . N GMTSED,DIE,DR,GMTSI,GMTST,GMTSV,GMTSDT S GMTSDT=$$NOW^XLFDT
93 . . S GMTSV=+($G(GMTS)),DIE="^GMT(142.5,",DR=".03////^S X=$G(GMTSV)"
94 . . S GMTSED=0 F GMTSI=1:1:3 Q:GMTSI>3 L +^GMT(142.5):0 H:'$T 1 I $T D
95 . . . D ^DIE S GMTSED=1 S $P(^GMT(142.5,+DA,0),U,19)=$$NOW^XLFDT,GMTSI=4
96 . . I 'GMTSED S GMTSQ=1 K GMTSOBJ W !," Record Locked by another user" Q
97 . . L -^GMT(142.5) S GMTST=+($P($G(^GMT(142.5,+DA,0)),U,3))
98 . . I +GMTST'>0,+DA>0 D NT^GMTSOBL2(GMTSY) Q
99 S X=+($G(DA))_"^"_$P($G(^GMT(142.5,+($G(DA)),0)),"^",1)
100 S:+GMTSNEW>0 X=X_"^"_+GMTSNEW
101 S X=$$VER^GMTSOBL2(X)
102 Q X
103TYPE(GMTS) ; Lookup HS Type
104 F S GMTS=$$TYPE^GMTSOBT Q:+GMTS>0!(X="@")!(X["^")!(X="")
105 S:X["^" X="^" S:X["^"!(X="@")!(X="") GMTS=-1
106 Q GMTS
107TY(GMTS) ; Lookup HS Type (Learn as you go)
108 N ADEL,B,BY,CHANGE,CNT,DA,DHD,DIC,DIE,DIK,DIR,DLAYGO,DR
109 N EXISTS,FLDS,FR,GMTSEG,GMTSIEN,GMTSDEF,GMTSIFN,GMTSMGR,GNTSN
110 N GMTSNEW,GMTSQIT,GMTSUM,L,LCNT,LI,NXTCMP,SELCNT,SOACTION,TO,TWEENER
111 N TYPE,Y S EXISTS=0,(GMTSDEF,X)=$G(GMTS),GMTSQIT=0
112 W:'$D(GMTSDICA) ! S U="^",DIC="^GMT(142,",DIC(0)="AEMQL"
113 S DIC("A")=" Select Health Summary Type: "
114 S:$L($G(GMTSDICA)) DIC("A")=$G(GMTSDICA)
115 S GMTSDEF=$S(+GMTSDEF>0:$P($G(^GMT(142,+GMTSDEF,0)),"^",1),1:"")
116 S:$L($G(GMTSDEF)) DIC("B")=$G(GMTSDEF)
117 S DIC("S")="I +($$AHST^GMTSULT(+($G(Y))))"
118 S DLAYGO=142,Y=$$TYPE^GMTSULT K DIC I +Y'>0 S X="@" Q -1
119 S (GMTSIFN,DA)=+Y,GMTSUM=$P(Y,U,2),GMTSNEW=+$P(Y,U,3)
120 S GMTSMGR=$S($D(^XUSEC("GMTSMGR",DUZ)):1,1:0)
121 I 'GMTSNEW S X=$S(+Y>0:+Y,1:"@"),GMTS=+Y Q GMTS
122 S DIE="^GMT(142,",(GMTSIFN,DA)=+Y,DR="[GMTS EDIT HLTH SUM TYPE]" D ^DIE
123 I '$D(^GMT(142,+GMTSIFN,0))!($D(Y))!$D(DUOUT)!$D(DIROUT)!$D(DTOUT) D Q -1
124 . S GMTSQIT=1 D CD S:'$D(^GMT(142,+GMTSIFN,0)) X="@"
125 D SELCMP^GMTSRM5 I GMTSQIT D DEL(GMTSIFN) Q -1
126 D LIST:EXISTS,EXISTS,CD S X=$S($D(^GMT(142,+($G(GMTSIFN)),0)):+GMTSIFN,1:-1)
127 K:+X>0 DTOUT,DUOUT,DIRUT,DIROUT S:+X>0 GMTSQ=0
128 Q X
129CD ; Check for Possible Deletion (New Type without Component)
130 Q:+($G(GMTSIFN))'>0 Q:'$D(^GMT(142,+($G(GMTSIFN)),0))
131 D:GMTSMGR!(GMTSNEW)!($P(^GMT(142,+GMTSIFN,0),U,3)'=$G(DUZ)) ADEL(+($G(GMTSIFN)))
132 Q
133EXISTS ; Edit an existing health summary type
134 N CNT,NXTCMP,GMTSQIT S GMTSQIT=0 Q:$D(DUOUT) S NXTCMP=0,NXTCMP(0)=0
135 F CNT=$$GETCNT(GMTSIFN):0 D NXTCMP^GMTSRM1 D LIST:GMTSQIT Q:GMTSQIT!($D(DUOUT)) K GMTSQIT,GMTSNEW,TWEENER,SOACTION
136 I NXTCMP>0 W !,"Please hold on while I resequence the summary order" D COPY^GMTSRN,RNMBR^GMTSRN:CHANGE
137 Q
138LIST ; Lists existing summary parameters
139 N B,DIC,DIR,IOP,Y,FR,TO,BY,DHD,FLDS,L I GMTSQIT'=2 Q:($D(DUOUT)!(GMTSQIT=1))
140 I GMTSQIT=2,(NXTCMP=0) S GMTSQIT=0 Q
141 I 'GMTSNEW 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
142 I $D(GMTSQIT),GMTSQIT=2 S GMTSQIT=0
143 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
144 Q
145GETCNT(GMTSIFN) ; Determine default summary order for new component
146 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
147 Q LCNT
148ADEL(X) ; Ask to Delete Type
149 N GMTSIEN,GMTSN,ADEL,DIR S GMTSIEN=+($G(X)),ADEL="" Q:GMTSIEN=0 Q:'$D(^GMT(142,GMTSIEN,0)) Q:$D(^GMT(142,GMTSIEN,1,"B"))
150 S GMTSN=$P($G(^GMT(142,GMTSIEN,0)),"^",1) Q:'$L(GMTSN) S DIR("A",1)=" Health Summary Type '"_GMTSN_"' has no Components",DIR("A")=" Do you want to delete this type? (Y/N) ",DIR("B")="Yes",DIR(0)="YAO",DIR("?")=" Enter either 'Y' or 'N'."
151 W ! D ^DIR D:Y>0 DEL(+($G(GMTSIEN)))
152 Q
153DEL(X) ; Delete Type
154 N DIK,DA,GMTSN S DA=+($G(X)) Q:DA=0 Q:'$D(^GMT(142,DA,0))
155 S DIK="^GMT(142,",GMTSN=$P($G(^GMT(142,DA,0)),"^",1) Q:'$L(GMTSN) D ^DIK
156 I '$D(^GMT(142,DA,0)) W:$D(ADEL) " < Health Summary Type deleted >" W:'$D(ADEL) !,?2,GMTSN," < deleted >"
157 Q
158K ; Kill Common Variables
159 K DTOUT,DUOUT,DIRUT,DIROUT
160 Q
161ABT(X) ; Abort
162 Q:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) 1
163 Q 0
164ST ; Show Type
165 N GMTSN,GMTSC S GMTSN="^GMT(142,"_+($G(GMTSIFN))_")",GMTSC="^GMT(142,"_+($G(GMTSIFN))_","
166 W ! F S GMTSN=$Q(@GMTSN) Q:GMTSN=""!(GMTSN'[GMTSC) W !,GMTSN,"=",@GMTSN
167 Q
Note: See TracBrowser for help on using the repository browser.