source: FOIAVistA/trunk/r/HEALTH_SUMMARY-GMTS/GMTSADH5.m@ 635

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

initial load of FOIAVistA 6/30/08 version
File size: 7.0 KB
Line 
1GMTSADH5 ; SLC/DCM,KER - Health Summary Ad Hoc RPC's ; 02/27/2002
2 ;;2.7;Health Summary;**36,35,37,49,63**;Oct 20, 1995
3 ;
4 ; External References
5 ; DBIA 1268 ^AUTTHF(
6 ; DBIA 1268 ^AUTTHF("B"
7 ; DBIA 67 ^LAB(60
8 ; DBIA 1256 ^PXD(811.9
9 ; DBIA 3059 ^TIU(8925.1
10 ; DBIA 10006 ^DIC
11 ; DBIA 2052 $$GET1^DID
12 ; DBIA 3058 $$ISA^TIULX
13 ;
14COMP(Y) ; Get ADHOC sub components (FILE 142.1)
15 ;
16 ; Y(i)=(1)I;IFN^(2)Component Name [Abb]^(3)Occ Limit^
17 ; (4)Time Limit^(5)Header Name^(6)Hosp Loc Disp^
18 ; (7)ICD Text Disp^(8)Prov Narr Disp^
19 ; (9)CPT Modifier Disp^(10)Summary Order
20 ;
21 N GMTSI,GMTSII,GMTSIFN,GMTSC,X,X1
22 S Y(1)=$O(^GMT(142,"B","GMTS HS ADHOC OPTION",0))
23 I 'Y(1) S Y(1)=-1 Q ; Error, no ADHOC type defined
24 S (GMTSC,GMTSI)=0,GMTSII=Y(1)
25 F S GMTSI=$O(^GMT(142,GMTSII,1,GMTSI)) Q:'GMTSI S X=^(GMTSI,0) D
26 . S GMTSIFN=$P(X,"^",2),X1=$G(^GMT(142.1,+GMTSIFN,0))
27 . Q:'$L(X1) Q:$P(X1,"^",6)="P" S GMTSC=GMTSC+1
28 . S Y(GMTSC)=GMTSI_";"_GMTSIFN
29 . S Y(GMTSC)=Y(GMTSC)_"^"_$P(X1,"^")_" ["_$P(X1,"^",4)_"]"
30 . S Y(GMTSC)=Y(GMTSC)_"^"_$S($P(X1,"^",5)="Y":$P(X,"^",3),1:"")
31 . S Y(GMTSC)=Y(GMTSC)_"^"_$S($P(X1,"^",3)="Y":$P(X,"^",4),1:"")
32 . S Y(GMTSC)=Y(GMTSC)_"^"_$S($L($P(X1,"^",9)):$P(X1,"^",9),1:$P(X,"^",5))
33 . S Y(GMTSC)=Y(GMTSC)_"^"_$S($P(X1,"^",10)="Y":$P(X,"^",6),1:"")
34 . S Y(GMTSC)=Y(GMTSC)_"^"_$S($P(X1,"^",11)="Y":$P(X,"^",7),1:"")
35 . S Y(GMTSC)=Y(GMTSC)_"^"_$S($P(X1,"^",12)="Y":$P(X,"^",8),1:"")
36 . S Y(GMTSC)=Y(GMTSC)_"^"_$P(X,"^")
37 Q
38 ;
39COMPSUB(Y,GMTSUB) ; Get subcomponents from a predefined ADHOC component
40 ; GMTSUB=desired Adhoc subcomponent
41 ; Y(i)=ifn of pointed to file entry^name
42 Q:'$G(GMTSUB)
43 N GMTSI,GMTSII,GMTSIFN,GMTSC,X,X1
44 S X=$O(^GMT(142,"B","GMTS HS ADHOC OPTION",0))
45 I 'X Q ; Error, no ADHOC type defined
46 S (GMTSC,GMTSI)=0,GMTSII=X
47 F S GMTSI=$O(^GMT(142,GMTSII,1,GMTSUB,1,GMTSI)) Q:'GMTSI S X=^(GMTSI,0) D
48 . S GMTSIFN=+X,X1=$P(X,";",2)
49 . I '$D(@("^"_X1_+X_",0)")) Q
50 . S X=@("^"_X1_+X_",0)"),GMTSC=GMTSC+1,Y(GMTSC)=GMTSIFN_"^"_$P(X,"^")
51 Q
52 ;
53FILES(Y,GMTSCP) ; Get Files to select from for a component
54 Q:'$G(GMTSCP) Q:'$D(^GMT(142.1,GMTSCP,1))
55 N GMTSGEC,GMTSI,GMTSC,X
56 S (GMTSGEC,GMTSI,GMTSC)=0
57 I $P($G(^GMT(142.1,GMTSCP,0)),U,4)="GECH" S GMTSGEC=1
58 F S GMTSI=$O(^GMT(142.1,GMTSCP,1,GMTSI)) Q:'GMTSI D
59 .S X=^(GMTSI,0),GMTSC=GMTSC+1 S:GMTSGEC=1 X=X_"G"
60 .S Y(GMTSC)=GMTSI_"^"_$$FNAM^GMTSU(+X)_"^"_X
61 Q
62 ;
63FILESEL(GMTSRT,GMTSFI,GMTSFM,DIR) ; Get file entries
64 Q:'$G(GMTSFI)
65 K ^TMP("ORDATA",$J)
66 N GMTSI,GMTSJ,GMTSC,X,GMTSGL,GMTSGLB,GMTSCNT,HFC
67 S GMTSI=$G(GMTSFM),GMTSCNT=44,GMTSC=0,GMTSRT=$NA(^TMP("ORDATA",$J,1))
68 S:'$D(DIR) DIR=1
69 I GMTSFI=60 D Q
70 . F Q:GMTSC'<GMTSCNT S GMTSI=$O(^LAB(60,"B",GMTSI),DIR) Q:GMTSI="" S GMTSJ=0 F S GMTSJ=$O(^LAB(60,"B",GMTSI,GMTSJ)) Q:'GMTSJ D
71 . . I $D(^LAB(60,GMTSJ,0)) S X=^(0) I $P(X,"^",4)="CH","BO"[$P(X,"^",3) S GMTSC=GMTSC+1,^TMP("ORDATA",$J,1,GMTSC)=GMTSJ_"^"_GMTSI
72 I GMTSFI="9999999.64G" D Q
73 . F Q:GMTSC'<GMTSCNT S GMTSI=$O(^AUTTHF("B",GMTSI),DIR) Q:GMTSI="" S GMTSJ=0 F S GMTSJ=$O(^AUTTHF("B",GMTSI,GMTSJ)) Q:'GMTSJ I $D(^AUTTHF(GMTSJ,0)) S X=^(0) D
74 ..I (($P(^(0),U,10)="C")&(+$P(^(0),U,11)'=1))&($P(^(0)," ",1)="GEC") D
75 ...S GMTSC=GMTSC+1
76 ...S HFC=$S($P($G(X),U,10)="F":"Factor",$P($G(X),U,10)="C":"Category")
77 ...S ^TMP("ORDATA",$J,1,GMTSC)=GMTSJ_U_GMTSI_" ("_HFC_")"
78 I GMTSFI=9999999.64 D Q
79 . F Q:GMTSC'<GMTSCNT S GMTSI=$O(^AUTTHF("B",GMTSI),DIR) Q:GMTSI="" S GMTSJ=0 F S GMTSJ=$O(^AUTTHF("B",GMTSI,GMTSJ)) Q:'GMTSJ I $D(^AUTTHF(GMTSJ,0)) S X=^(0) D
80 ..I +$P(X,U,11)'=1 D
81 ...S GMTSC=GMTSC+1
82 ...S HFC=$S($P($G(X),U,10)="F":"Factor",$P($G(X),U,10)="C":"Category")
83 ...S ^TMP("ORDATA",$J,1,GMTSC)=GMTSJ_U_GMTSI_" ("_HFC_")"
84 I GMTSFI=811.9 D Q
85 . F Q:GMTSC'<GMTSCNT S GMTSI=$O(^PXD(811.9,"B",GMTSI),DIR) Q:GMTSI="" S GMTSJ=0 F S GMTSJ=$O(^PXD(811.9,"B",GMTSI,GMTSJ)) Q:'GMTSJ I $D(^PXD(811.9,GMTSJ,0)) S X=^(0) D
86 . . I $P(X,"^",6)'=1 S GMTSC=GMTSC+1,^TMP("ORDATA",$J,1,GMTSC)=GMTSJ_"^"_GMTSI
87 I GMTSFI=8925.1 D Q
88 . F Q:GMTSC'<GMTSCNT S GMTSI=$O(^TIU(8925.1,"B",GMTSI),DIR) Q:GMTSI="" S GMTSJ=0 F S GMTSJ=$O(^TIU(8925.1,"B",GMTSI,GMTSJ)) Q:'GMTSJ I $D(^TIU(8925.1,GMTSJ,0)) S X=^(0) D
89 . . I $P(X,"^",4)="DOC",$$ISA^TIULX(GMTSJ,3) S GMTSC=GMTSC+1,^TMP("ORDATA",$J,1,GMTSC)=GMTSJ_"^"_GMTSI
90 ;I GMTSFI=81 D Q
91 ;. F Q:GMTSC'<GMTSCNT S GMTSI=$O(^ICPT("C",GMTSI),DIR) Q:GMTSI="" S GMTSJ=0 F S GMTSJ=$O(^ICPT("C",GMTSI,GMTSJ)) Q:'GMTSJ I $D(^ICPT(GMTSJ,0)) S X=^(0) D
92 ;. . S GMTSC=GMTSC+1,^TMP("ORDATA",$J,1,GMTSC)=GMTSJ_"^"_$P(X,"^",2)_" ["_$P(X,"^")_"]"
93 S GMTSGL=$$FCLR^GMTSU(+GMTSFI) I $L(GMTSGL) S GMTSGLB=$$FLOC^GMTSU(+GMTSFI)_"""B"")" D
94 . F Q:GMTSC'<GMTSCNT S GMTSI=$O(@GMTSGLB@(GMTSI),DIR) Q:GMTSI="" S GMTSJ=0 F S GMTSJ=$O(@GMTSGLB@(GMTSI,GMTSJ)) Q:'GMTSJ I $D(@GMTSGL@(GMTSJ,0)) S X=^(0) D
95 . . S GMTSC=GMTSC+1,^TMP("ORDATA",$J,1,GMTSC)=GMTSJ_"^"_GMTSI
96 Q
97 ;
98REPORT(GMTSEG,GMTSEGC,GMTSEGI,GMTSCPS,DFN) ; Build Report
99 ; Uses array of Components passed in GMTSCPS()
100 ; GMTSCPS(i)=array of subcomponents chosen,
101 ; value is pointer at ^GMT(142,DA(1),1,DA)
102 Q:'$G(DFN)
103 N GMTSCNT,DIC,DIZ,DIW,DIWI,DIWT,DIWTC,X,GMTSI,GMTSJ,GMTSK,GMTSTYP,GMTSTITL
104 S X="GMTS HS ADHOC",DIC=142,DIZ(0)="ZF"
105 D ^DIC Q:'Y
106 S GMTSTYP=+Y,GMTSTITL="AD HOC",(GMTSJ,GMTSI)=0,GMTSEGC=$O(GMTSCPS(99999999),-1)
107 F S GMTSI=$O(GMTSCPS(GMTSI)) Q:'GMTSI D
108 . N GMTSREC,GMTSS2,GMTSSJ,GMTSEL
109 . S GMTSREC=^GMT(142,GMTSTYP,1,+GMTSCPS(GMTSI),0),GMTSJ=GMTSJ+1
110 . S GMTSEG(GMTSJ)=GMTSREC,GMTSEGI($P(GMTSREC,U,2))=GMTSJ,GMTSS2=0,GMTSSJ=GMTSJ
111 . S $P(GMTSEG(GMTSJ),"^",3)=$P(GMTSCPS(GMTSI),"^",2)
112 . S $P(GMTSEG(GMTSJ),"^",4)=$P(GMTSCPS(GMTSI),"^",3)
113 . I $L($P(GMTSCPS(GMTSI),"^",4)) S $P(GMTSEG(GMTSJ),"^",5)=$P(GMTSCPS(GMTSI),"^",4)
114 . I $L($P(GMTSCPS(GMTSI),"^",5)) S $P(GMTSEG(GMTSJ),"^",6)=$P(GMTSCPS(GMTSI),"^",5)
115 . S $P(GMTSEG(GMTSJ),"^",7)=$P(GMTSCPS(GMTSI),"^",6)
116 . I $L($P(GMTSCPS(GMTSI),"^",7)) S $P(GMTSEG(GMTSJ),"^",8)=$P(GMTSCPS(GMTSI),"^",7)
117 . S (GMTSCNT,GMTSK)=0
118 . F S GMTSK=$O(GMTSCPS(GMTSK)) Q:'GMTSK D
119 . .I $P($G(GMTSCPS(GMTSK)),U,9)="9999999.64G" S $P(GMTSCPS(GMTSK),U,9)="9999999.64"
120 . .I +GMTSCPS(GMTSI)=+GMTSCPS(GMTSK),$P(GMTSCPS(GMTSK),"^",9),$P(GMTSCPS(GMTSK),"^",10) D
121 . . . S GMTSCNT=GMTSCNT+1
122 . . . S:'$D(GMTSEG(GMTSJ,$P(GMTSCPS(GMTSK),"^",9),0)) GMTSEG(GMTSJ,$P(GMTSCPS(GMTSK),"^",9),0)=$$GET1^DID($P(GMTSCPS(GMTSK),"^",9),,,"GLOBAL NAME")
123 . . . S GMTSEG(GMTSJ,$P(GMTSCPS(GMTSK),"^",9),GMTSCNT)=$P(GMTSCPS(GMTSK),"^",10)
124 . . . K GMTSCPS(GMTSK)
125 Q
126 ;
127SUBITEM(Y,GMTSTEST) ; Get Subitems for a Test Panel
128 Q:'$G(GMTSTEST) N GMTSCNT S GMTSCNT=0
129 I '$L($P(^LAB(60,GMTSTEST,0),"^",5)),$O(^LAB(60,GMTSTEST,2,0)) D COMPILE(GMTSTEST,GMTSCNT)
130 Q
131 ;
132COMPILE(GMTSTEST,GMTSCNT) ; Expand lab panels
133 N GMTSI,GMTSJ,GMTSRT S GMTSI=0
134 F S GMTSI=$O(^LAB(60,GMTSTEST,2,GMTSI)) Q:GMTSI'>0 D
135 . S GMTSJ=+$G(^LAB(60,GMTSTEST,2,+GMTSI,0))
136 . S GMTSRT=$G(^LAB(60,+GMTSJ,0))
137 . I $L($P(GMTSRT,U,5)),("BO"[$P(GMTSRT,U,3)) D
138 . . S GMTSCNT=GMTSCNT+1
139 . . S Y(GMTSCNT)=+GMTSJ_"^"_GMTSRT
140 . E D
141 . . D COMPILE(+$G(^LAB(60,GMTSTEST,2,GMTSI,0)),GMTSCNT)
142 Q
Note: See TracBrowser for help on using the repository browser.