source: FOIAVistA/trunk/r/HEALTH_SUMMARY-GMTS/GMTSXPD4.m@ 1657

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

initial load of FOIAVistA 6/30/08 version
File size: 7.1 KB
Line 
1GMTSXPD4 ; SLC/KER - Health Summary Dist (Re-Build) ; 08/27/2002
2 ;;2.7;Health Summary;**35,56**;Oct 20, 1995
3 ;
4 ; External References
5 ; DBIA 10013 ^DIK (file #142)
6 ; DBIA 2052 $$GET1^DID
7 ; DBIA 10018 ^DIE (file #142)
8 ; DBIA 10086 HOME^%ZIS
9 ; DBIA 10060 ^VA(200,
10 ; DBIA 2056 $$GET1^DIQ (file 200)
11 ; DBIA 10141 BMES^XPDUTL
12 ; DBIA 10141 MES^XPDUTL
13 ;
14 Q
15 ; Re-Build Ad Hoc Health Summary Type
16 ;
17 ; Input Variables INCLUDE
18 ; 0 exclude DISABLED components
19 ; 1 include DISABLED components
20 ;
21IN ; Re-Build w/INCLUDE
22 N INCLUDE S INCLUDE=1 D RB Q
23EX ; Re-Build w/EXCLUDE
24 N INCLUDE S INCLUDE=0 D RB Q
25RB ; Re-Build (main)
26 N GMTSENV S GMTSENV=$$ENV Q:'GMTSENV
27 N DA,DIC,DIE,DIK,DLAYGO,DR,GMTSC,GMTSDA,GMTSDIAB,GMTSE,GMTSEG,GMTSEL
28 N GMTSELC,GMTSELT,GMTSEQ,GMTSI,GMTSICD,GMTSIFN,GMTSISEQ,GMTSITEM
29 N GMTSJ,GMTSL,GMTSLOC,GMTSNAR,GMTSCPT,GMTSNEW,GMTSNM,GMTSOCC,GMTSOK
30 N GMTSORD,GMTSQ,GMTST1,GMTST2,GMTST3,GMTSTIM,GMTSTYP,X,Y
31 S GMTSOK=0,GMTSE=59,GMTSC=0 D BM(" Ad Hoc Summary") S GMTST1=" Gathering Ad Hoc Summary information",GMTST2=" Purging old Ad Hoc Summary",GMTST3=" Rebuilding Ad Hoc Summary"
32 D M($G(GMTST1)) N GMTSNEW,GMTSTYP,DLAYGO S DLAYGO=142
33 S DIC=142,DIC(0)="LXF",X="GMTS HS ADHOC OPTION" S Y=$$TYPE^GMTSULT K DIC
34 I +Y'>0 D BM("** GMTS AD HOC OPTION Summary Type is missing **") Q
35 D GA,RN D:+($G(GMTSOK))>0 BM(" Ad Hoc Health Summary successfully rebuilt")
36 D:+($G(GMTSOK))'>0 BM(" Failed to successfully rebuild the Ad Hoc Health Summary")
37 Q
38GA ; Gather Information
39 N GMTSL,GMTSQ,GMTSC,GMTSE
40 S GMTSE=59,GMTSC=0,GMTSL=$L($G(GMTST1))
41 S (GMTSIFN,GMTSTYP)=+Y,GMTSNEW=+$P(Y,"^",3)
42 S:'$D(^GMT(142,GMTSIFN,1,0)) ^(0)="^142.01IA^0^0"
43 S GMTSC=0,GMTSNM="" F GMTSC=1:1 S GMTSNM=$O(^GMT(142.1,"B",GMTSNM)) Q:GMTSNM']"" S GMTSC=+($G(GMTSC))+1
44 S GMTSC=GMTSC-1,GMTSQ=GMTSC\(GMTSE-$L(GMTST1))
45 S GMTSC=0,GMTSNM="" F GMTSC=1:1 S GMTSNM=$O(^GMT(142.1,"B",GMTSNM)) Q:GMTSNM']"" D
46 . S GMTSJ=$O(^(GMTSNM,0)) Q:GMTSJ'>0 D LA
47 . Q:$D(GMTSQT) Q:+GMTSQ'>0
48 . S GMTSC=GMTSC+1 S:GMTSC#GMTSQ=0 GMTSL=GMTSL+1 Q:GMTSL>GMTSE
49 . W:GMTSC#GMTSQ=0 "."
50 I '$D(GMTSQT),GMTSL'>GMTSE F S GMTSL=GMTSL+1 Q:GMTSL>GMTSE W "."
51 W:'$D(GMTSQT) ?GMTSE," < done >"
52 S GMTSI=0 I 'GMTSNEW D PA
53 Q
54PA ; Purge Ad Hoc Health Summary
55 N GMTSI,GMTSL,GMTSQ,GMTSC,GMTSE S GMTSE=59,GMTSL=$L($G(GMTST2)) D M($G(GMTST2))
56 S (GMTSC,GMTSI)=0 F S GMTSI=$O(^GMT(142,GMTSIFN,1,GMTSI)) Q:GMTSI'>0 S GMTSC=+($G(GMTSC))+1
57 S GMTSC=GMTSC-1,GMTSQ=GMTSC\(GMTSE-$L(GMTST1))
58 S (GMTSC,GMTSI)=0 F S GMTSI=$O(^GMT(142,GMTSIFN,1,GMTSI)) Q:GMTSI'>0 D
59 . N DA,DIK S U="^",DA(1)=GMTSIFN,DA=GMTSI,DIK="^GMT(142,"_GMTSIFN_",1," D ^DIK
60 . Q:$D(GMTSQT) Q:+GMTSQ'>0
61 . S GMTSC=GMTSC+1 S:GMTSC#GMTSQ=0 GMTSL=GMTSL+1 Q:GMTSL>GMTSE
62 . W:GMTSC#GMTSQ=0 "."
63 I '$D(GMTSQT),GMTSL'>GMTSE F S GMTSL=GMTSL+1 Q:GMTSL>GMTSE W "."
64 W:'$D(GMTSQT) ?GMTSE," < done >"
65 Q
66RN ; Renumber - Resets ^GMT(142,GMTSIFN,1,
67 N DA,DR,DIE,GMTSEQ,GMTSL
68 N GMTSL,GMTSQ,GMTSC,GMTSE S GMTSE=59,GMTSL=$L($G(GMTST3)) D M($G(GMTST3))
69 S (GMTSEQ,GMTSC)=0 F S GMTSEQ=$O(GMTSEG(GMTSEQ)) Q:GMTSEQ'>0 S GMTSC=+($G(GMTSC))+1
70 S GMTSC=GMTSC-1,GMTSQ=GMTSC\(GMTSE-$L(GMTST3))
71 S (GMTSEQ,GMTSC)=0 F S GMTSEQ=$O(GMTSEG(GMTSEQ)) Q:GMTSEQ'>0 D
72 . K DA S DIE="^GMT(142,"_GMTSIFN_",1,",DA(1)=GMTSIFN D AC
73 . Q:$D(GMTSQT) Q:+GMTSQ'>0
74 . S GMTSC=GMTSC+1 S:GMTSC#GMTSQ=0 GMTSL=GMTSL+1 Q:GMTSL>GMTSE
75 . W:GMTSC#GMTSQ=0 "."
76 I '$D(GMTSQT),GMTSL'>GMTSE F S GMTSL=GMTSL+1 Q:GMTSL>GMTSE W "."
77 W:'$D(GMTSQT) ?GMTSE," < done >" S GMTSOK=1
78 Q
79LA ; Load Array GMTSEG(#)
80 N GMTSOCC,GMTSTIM,GMTSORD,GMTSLOC,GMTSICD,GMTSNAR,GMTSCPT
81 Q:'$D(^GMT(142.1,GMTSJ,0))
82 S GMTSORD=$O(^GMT(142,"AE",GMTSJ,GMTSTYP,0))
83 I GMTSORD>0 D
84 . S GMTSOCC=$S($P(^GMT(142.1,GMTSJ,0),"^",5)="Y":$P($G(^GMT(142,GMTSTYP,1,GMTSORD,0)),"^",3),1:"")
85 . S GMTSTIM=$S($P(^GMT(142.1,GMTSJ,0),"^",3)="Y":$P($G(^GMT(142,GMTSTYP,1,GMTSORD,0)),"^",4),1:"")
86 . S GMTSLOC=$S($P(^GMT(142.1,GMTSJ,0),"^",10)="Y":$P($G(^GMT(142,GMTSTYP,1,GMTSORD,0)),"^",6),1:"")
87 . S GMTSICD=$S($P(^GMT(142.1,GMTSJ,0),"^",11)="Y":$P($G(^GMT(142,GMTSTYP,1,GMTSORD,0)),"^",7),1:"")
88 . S GMTSNAR=$S($P(^GMT(142.1,GMTSJ,0),"^",12)="Y":$P($G(^GMT(142,GMTSTYP,1,GMTSORD,0)),"^",8),1:"")
89 . S GMTSCPT=$S($P(^GMT(142.1,GMTSJ,0),"^",14)="Y":$P($G(^GMT(142,GMTSTYP,1,GMTSORD,0)),"^",9),1:"")
90 E D
91 . S GMTSOCC=$S($P(^GMT(142.1,GMTSJ,0),"^",5)="Y":10,1:"")
92 . S GMTSTIM=$S($P(^GMT(142.1,GMTSJ,0),"^",3)="Y":"1Y",1:"")
93 . S GMTSLOC=$S($P(^GMT(142.1,GMTSJ,0),"^",10)="Y":"Y",1:"")
94 . S GMTSICD=$S($P(^GMT(142.1,GMTSJ,0),"^",11)="Y":"L",1:"")
95 . S GMTSNAR=$S($P(^GMT(142.1,GMTSJ,0),"^",12)="Y":"Y",1:"")
96 . S GMTSCPT=$S($P(^GMT(142.1,GMTSJ,0),"^",12)="Y":"Y",1:"")
97 ; Defaults for CPT Modifiers
98 S:$P(^GMT(142.1,GMTSJ,0),"^",14)="Y"&(GMTSCPT="") GMTSCPT="Y"
99 S:$$GET1^DID(142.1,14,,"LABEL")="" GMTSCPT=""
100 D SG
101 Q
102SG ; Set GMTSEG(#) Component
103 ; Disabled
104 N GMTSDIAB S GMTSDIAB=$S($P(^GMT(142.1,GMTSJ,0),"^",6)="P":1,$P(^(0),"^",6)="T":1,1:0) I (INCLUDE=0),(GMTSDIAB=1) Q
105 ; Include
106 S GMTSEG(GMTSC)=(5*GMTSC)_"^"_GMTSJ_"^"_GMTSOCC_"^"_GMTSTIM_"^^"_GMTSLOC_"^"_GMTSICD_"^"_GMTSNAR_"^"_GMTSCPT I GMTSORD>0 D SL
107 Q
108SL ; Set GMTSEG(#,#) Selection item
109 N GMTSELT,GMTSITEM
110 S GMTSELT=0 F S GMTSELT=$O(^GMT(142,GMTSTYP,1,+GMTSORD,1,GMTSELT)) Q:GMTSELT'>0 D
111 . S GMTSITEM=^(GMTSELT,0) S GMTSEG(GMTSC,GMTSELT)=GMTSITEM
112 Q
113AC ; Add Components to Ad Hoc Summary
114 N GMTSISEQ,DA,DIE,DR,GMTSELC,GMTSDA,GMTSEL
115 S (GMTSISEQ,DA)=GMTSEQ*5,DIE="^GMT(142,"_GMTSIFN_",1,",DA(1)=GMTSIFN
116 S DR=".01///"_DA
117 S:$L($P(GMTSEG(GMTSEQ),"^",2)) DR=DR_";1///"_$P(GMTSEG(GMTSEQ),"^",2)
118 S:$L($P(GMTSEG(GMTSEQ),"^",3)) DR=DR_";2///"_$P(GMTSEG(GMTSEQ),"^",3)
119 S:$L($P(GMTSEG(GMTSEQ),"^",4)) DR=DR_";3///"_$P(GMTSEG(GMTSEQ),"^",4)
120 S:$L($P(GMTSEG(GMTSEQ),"^",5)) DR=DR_";5///"_$P(GMTSEG(GMTSEQ),"^",5)
121 S:$L($P(GMTSEG(GMTSEQ),"^",6)) DR=DR_";6///"_$P(GMTSEG(GMTSEQ),"^",6)
122 S:$L($P(GMTSEG(GMTSEQ),"^",7)) DR=DR_";7///"_$P(GMTSEG(GMTSEQ),"^",7)
123 S:$L($P(GMTSEG(GMTSEQ),"^",8)) DR=DR_";8///"_$P(GMTSEG(GMTSEQ),"^",8)
124 S:$L($P($G(GMTSEG(GMTSEQ)),"^",9))>0&($L($$GET1^DID(142.1,14,,"LABEL"))>0) DR=DR_";9///"_$P(GMTSEG(GMTSEQ),"^",9)
125 D ^DIE S (GMTSELC,GMTSEL)=0 F S GMTSEL=$O(GMTSEG(GMTSEQ,GMTSEL)) Q:'GMTSEL D AS
126 I GMTSELC>0 S:'$D(^GMT(142,GMTSIFN,1,GMTSISEQ,1,0)) ^(0)="^142.14V^"_GMTSDA_"^"_GMTSELC
127 Q
128AS ; Add Selection Items to Ad Hoc Summary
129 N DIE,DA,DR
130 S:'$D(^GMT(142,GMTSIFN,1,GMTSISEQ,1,0)) ^(0)="^142.14V^^"
131 S DIE="^GMT(142,"_GMTSIFN_",1,"_GMTSISEQ_",1,"
132 S DA(2)=GMTSIFN,DA(1)=GMTSISEQ,DA=GMTSEL
133 S DR=".01////"_"^S X=GMTSEG(GMTSEQ,GMTSEL)" D ^DIE
134 S GMTSDA=DA,GMTSELC=GMTSELC+1
135 Q
136 ;
137 ; Misc
138ENV(X) ; Environment check
139 D HOME^%ZIS I +($G(DUZ))=0 D BM(" User (DUZ) not defined"),M(" ") Q 0
140 I '$L($$GET1^DIQ(200,(+($G(DUZ))_","),.01)) D BM(" Invalid User defined (DUZ)"),M(" ") Q 0
141 Q 1
142BM(X) ; Blank Line with Message
143 Q:$D(GMTSQT) D:$D(XPDNM) BMES^XPDUTL($G(X)) W:'$D(XPDNM) !!,$G(X) Q
144M(X) ; Message
145 Q:$D(GMTSQT) D:$D(XPDNM) MES^XPDUTL($G(X)) W:'$D(XPDNM) !,$G(X) Q
146UP(X) ; Uppercase
147 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
Note: See TracBrowser for help on using the repository browser.