source: FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBAB1.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 7.2 KB
Line 
1DVBAB1 ;ALB/SPH - CAPRI UTILITIES ;01/01/00
2 ;;2.7;AMIE;**35,37,50,42,53,57,73,104,109**;Apr 10, 1995
3 ;
4VERSION(ZMSG,DVBGUIV) ;
5 ; Must have a letter at the end of the Version for Delphi compatibility
6 ; 1st piece is version description
7 ; 2nd piece can be YESOLD or NOOLD
8 ; YESOLD = Allow old GUI to run with new KID
9 ; NOOLD = Do not allow old GUI to run with newer version
10 S ZMSG="CAPRI GUI V2.7*71*1*A^NOOLD"
11 S DVBABVR1="CAPRI Server Version: "+ZMSG
12 I '$D(DVBGUIV) S DVBGUIV="CAPRI GUI Version: UNKNOWN - Version is prior to DVBA*2.7*71"
13 S DVBABVR2="CAPRI GUI Version: "+DVBGUIV
14 S DVBABVR3=$P(^VA(200,DUZ,0),"^",1)
15 Q
16 ;
17REQUESTS(Y,TYPE) ;
18 ; TYPE is the internal value of field 17 in file 396.3
19 ; This relates to which status of request should be returned
20 N DVBABCNT,DVBABIEN
21 S DVBABCNT=0,DVBABIEN=0
22 F S DVBABIEN=$O(^DVB(396.3,DVBABIEN)) Q:'DVBABIEN D
23 .S DVBABST=$P($G(^DVB(396.3,DVBABIEN,0)),"^",18)
24 .I DVBABST=TYPE D
25 ..S DVBABNM=$P($G(^DVB(396.3,DVBABIEN,0)),"^",1)
26 ..S DVBABPT=DVBABNM
27 ..I DVBABNM'="" S DVBABNM=$P($G(^DPT(DVBABNM,0)),"^",1)
28 ..S DVBABDT=$$FMTE^XLFDT($P($G(^DVB(396.3,DVBABIEN,0)),"^",2),"2D")
29 ..S DVBABWHO=$P($G(^DVB(396.3,DVBABIEN,0)),"^",4)
30 ..I DVBABWHO'="" S DVBABWHO=$P($G(^VA(200,DVBABWHO,0)),"^",1)
31 ..E S DVBABWHO="UNKNOWN"
32 ..S DVBABRO=$P($G(^DVB(396.3,DVBABIEN,0)),"^",3)
33 ..I DVBABRO'="" S DVBABRO=$P($G(^DIC(4,DVBABRO,0)),"^",1)
34 ..E S DVBABRO="UNKNOWN"
35 ..S ^TMP("DVBAREQ",DUZ,DVBABCNT)=DVBABST_"^"_DVBABPT_"^"_DVBABNM_"^"_DVBABDT_"^"_DVBABWHO_"^"_DVBABRO_"^"_DVBABIEN_$C(13),DVBABCNT=DVBABCNT+1
36 S Y=$NA(^TMP("DVBAREQ",DUZ))
37 K DVBABCNT,DVBABIEN,TYPE,DVBABNM,DVBABDT,DVBABST,DVBABWHO,DVBABPT
38 Q
39TEAMPTS(DVBORY,TEAM,TMPFLAG) ; RETURN LIST OF PATIENTS IN A TEAM
40 ; If TMPFLAG passed and = TRUE, code expects a "^TMP(xxx"
41 ; global root string passed in ORY, and builds the returned
42 ; list in that global instead of to a memory array.
43 N DOTMP,NEWTMP,DVBSSN,DVBORI,DVBORPT,I
44 K ^TMP("DVBATMPT",DUZ)
45 S (I,DOTMP,DVBORI)=0
46 I $G(TMPFLAG) D ; Was value passed?
47 .I TMPFLAG S DOTMP=1 ; Is value TRUE?
48 I +$G(TEAM)<1 D
49 .I DOTMP S NEWTMP=DVBORY_1_")",@NEWTMP="^No team identified"
50 .E S DVBORY(1)="^No team identified"
51 F S DVBORI=$O(^OR(100.21,+TEAM,10,DVBORI)) Q:DVBORI<1 D
52 .S DVBORPT=^OR(100.21,+TEAM,10,DVBORI,0)
53 .I DOTMP D
54 ..S I=I+1,NEWTMP=DVBORY_+I_")"
55 ..S @NEWTMP=+DVBORPT_U_$P(^DPT(+DVBORPT,0),U)
56 .S DVBSSN=$P($G(^DPT($P(DVBORPT,";",1),0)),U,9)
57 .E S I=I+1,^TMP("DVBATMPT",DUZ,I)=+DVBORPT_U_$P(^DPT(+DVBORPT,0),U)_U_DVBSSN_$C(13)
58 I DOTMP S:I<1 NEWTMP=DVBORY_1_")",@NEWTMP="^No patients found."
59 E S:I<1 ^TMP("DVBATMPT",DUZ,1)="^No patients found."
60 S DVBORY=$NA(^TMP("DVBATMPT",DUZ))
61 Q
62DIVISION(Y) ; Returns Name for an Institution
63 N DVBARR,DVBERR,DVBATP
64 S Y=""
65 Q:$G(DUZ(2))=""
66 D GETS^DIQ(4,DUZ(2)_",0",".01","I","DVBARR","DVBERR")
67 Q:$D(DVBERR)
68 S Y=$G(DVBARR(4,DUZ(2)_",0,",.01,"I"))
69 D GETS^DIQ(4,DUZ(2)_",0",13,"I","DVBARR","DVBERR")
70 S DVBATP=$G(DVBARR(4,DUZ(2)_",0,",13,"I"))
71 I DVBATP'="" S DVBATP=$P($G(^DIC(4.1,DVBATP,0)),"^",1)
72 S Y=Y_"-"_DVBATP
73 Q
74 ;
75DT(Y,X1,X2) ; Returns date X1 minus X2 days
76 ; change the '00:00' that could be passed so Fileman doesn't reject
77 ;C^%DTC(X1,X2)
78 ;S %DT=$G(%DT,"TS") D ^%DT
79 ;K %DT,X1,X2
80 ;Q
81DTTM(Y) ;
82 S Y=$$HTE^XLFDT($H,"P")
83 Q
84CHKCRED(Y) ;KLB
85 S Y="[OK]"
86 I '$D(DUZ(2)) S Y="Your division number is missing." Q
87 I $D(DUZ)#2=0 S Y="Your user number is invalid." Q
88 I +DUZ(2)<1 S Y="Invalid division."
89 Q
90PTINQ(REF,DFN) ; Return formatted pt inquiry report
91 K ^TMP("ORDATA",$J,1)
92 ; DVBA*2.7*109 - Added $D to next line
93 I ($D(^DPT(DFN,0))) D START^ORWRP(80,"DGINQB^ORCXPND1(DFN)")
94 S REF=$NA(^TMP("ORDATA",$J,1))
95 Q
96TEMPLATE(Y) ; Returns list of CAPRI exam templates
97 N DVBABCNT,DVBABIEN,DVBABNM,DVBABAD,DVBABDD,DVBABSL,DVBABOC
98 K Y,^TMP("DVBALAB1",DUZ)
99 S DVBABCNT=0,DVBABIEN=0
100 F S DVBABIEN=$O(^DVB(396.18,DVBABIEN)) Q:'DVBABIEN D
101 .S DVBABNM=$P($G(^DVB(396.18,DVBABIEN,0)),"^",1)
102 .S DVBABAD=$P($G(^DVB(396.18,DVBABIEN,2)),"^",1)
103 .S DVBABDD=$P($G(^DVB(396.18,DVBABIEN,2)),"^",2)
104 .S DVBABSL=$P($G(^DVB(396.18,DVBABIEN,6)),"^",1)
105 .S DVBABOC=$P($G(^DVB(396.18,DVBABIEN,6)),"^",2)
106 .S ^TMP("DVBATMPL",DUZ,DVBABCNT)=DVBABNM_"^"_DVBABAD_"^"_DVBABDD_"^"_DVBABSL_"^"_DVBABOC_"^"_DVBABIEN_$C(13),DVBABCNT=DVBABCNT+1
107 S Y=$NA(^TMP("DVBATMPL",DUZ))
108 Q
109 ;
110LABLIST(Y) ; Returns list of LAB TEST NAMES
111 N DVBABCNT,DVBABIEN,DVBABLNM
112 K Y,^TMP("DVBALAB1",DUZ)
113 S DVBABCNT=0,DVBABIEN=0
114 F S DVBABIEN=$O(^LAB(60,DVBABIEN)) Q:'DVBABIEN D
115 .S DVBABLNM=$P($G(^LAB(60,DVBABIEN,0)),"^",1)
116 .S ^TMP("DVBALAB1",DUZ,DVBABCNT)=DVBABLNM_"^"_DVBABIEN_$C(13),DVBABCNT=DVBABCNT+1
117 S Y=$NA(^TMP("DVBALAB1",DUZ))
118 Q
119 ;
120INSTLIST(Y) ; Returns full list of Institutions
121 N DVBABCNT,DVBABIEN,DVBABNM,DVBABSTN,DVBABST,DVBABDS,DVBARR,DVBERR,DVBATP
122 K Y,^TMP("DVBAINST",$J,DUZ)
123 S (DVBABCNT,DVBABIEN)=0
124 F S DVBABIEN=$O(^DIC(4,DVBABIEN)) Q:'DVBABIEN D
125 . K DVBARR,DVBERR
126 . D GETS^DIQ(4,DVBABIEN_",0",".01:.02:.03:","I","DVBARR","DVBERR")
127 . Q:$D(DVBERR)
128 . S DVBABNM=$G(DVBARR(4,DVBABIEN_",0,",.01,"I"))
129 . Q:DVBABNM=""
130 . S DVBABSTN=$G(DVBARR(4,DVBABIEN_",0,",.02,"I"))
131 . Q:DVBABSTN=""
132 . S DVBABDS=$G(DVBARR(4,DVBABIEN_",0,",.03,"I"))
133 . K DVBARR,DVBERR
134 . D GETS^DIQ(5,DVBABSTN_",0",.01,"I","DVBARR","DVBERR")
135 . Q:$D(DVBERR)
136 . S DVBABST=$G(DVBARR(5,DVBABSTN_",0,",.01,"I"))
137 . K DVBARR,DVBERR
138 . D GETS^DIQ(4,DVBABIEN_",0",13,"I","DVBARR","DVBERR")
139 . S DVBATP=$G(DVBARR(4,DVBABIEN_",0,",13,"I"))
140 . I DVBATP'="" D
141 .. S DVBATP=$P($G(^DIC(4.1,DVBATP,0)),"^",1)
142 . S ^TMP("DVBAINST",$J,DUZ,DVBABCNT)=DVBABNM_"-"_DVBATP_"^"_DVBABST_"^"_DVBABDS_"^"_DVBABIEN_$C(13)
143 . S DVBABCNT=DVBABCNT+1
144 S Y=$NA(^TMP("DVBAINST",$J,DUZ))
145 Q
146 ;
147INCEXAM(ZMSG) ;Increased exam # in file and passes back the # to user
148 S ZMSG=+$G(^DVB(396.1,1,5))+1
149 S ^DVB(396.1,1,5)=ZMSG
150 Q
151 ;
152MSG(ERR,DUZ,XMSUB,XMTEXT,MGN) ;Generate mail message;KLB
153 S ERR=""
154 K ^TMP($J,"AMIE")
155 I '$D(DUZ) S ERR="MISSING DUZ" Q
156 I '$D(XMSUB) S ERR="MISSING SUBJECT" Q
157 I '$D(XMTEXT) S ERR="MISSING TEXT" Q
158 I '$D(MGN) S ERR="MISSING MAIL GROUP NAME" Q
159 S XMDUZ=DUZ,J=0
160 F S J=$O(XWBS1(J)) Q:'J S ^TMP($J,"AMIE",J)=$G(XWBS1(J))
161 S XMTEXT="^TMP($J,""AMIE"","
162 S DIC="^XMB(3.8,",DIC(0)="QM",X=MGN D ^DIC
163 S MG=+Y
164 I +Y<0 S ERR="INVALID MAIL GROUP NAME" Q
165 I '$$GOTLOCAL^XMXAPIG(MGN) S ERR="NO ACTIVE LOCAL MEMBERS IN MAIL GROUP" K ^TMP("XMERR",$J) Q
166 S ZZ=0,ZZ1=0
167 F S ZZ=$O(^XMB(3.8,MG,1,"B",ZZ)) Q:'ZZ D
168 .F S ZZ1=$O(^XMB(3.8,MG,1,"B",ZZ,ZZ1)) Q:'ZZ1 S XMY(ZZ)=""
169 D ^XMD
170 I $D(XMMG) S ERR=XMMG
171 E S ERR="MESSAGE SENT"
172 K XMSUB,XMTEXT,MGN,DIC,DIC(0),ZZ,XMY,XWBS1,J,ZZ1,MG,^TMP($J,"AMIE"),XMMG,Y,XMDUZ
173 Q
174FINDEXAM(ZMSG,ZIEN) ;Returns list of exams in 396.4 that are linked to ZIEN in 396.3
175 N DVBABCNT,DVBABIEN
176 S DVBABCNT=0,DVBABIEN=0
177 F S DVBABIEN=$O(^DVB(396.4,"C",ZIEN,DVBABIEN)) Q:'DVBABIEN D
178 .S DVBABD1=$P($G(^DVB(396.4,DVBABIEN,0)),"^",2)
179 .S DVBABD2=$P($G(^DVB(396.6,+$P($G(^DVB(396.4,DVBABIEN,0)),"^",3),0)),"^",1) ;Name of Exam
180 .S DVBABD3=$P($G(^DVB(396.4,DVBABIEN,0)),"^",4)
181 .I DVBABD3="O" S DVBABD3="[OPEN]"
182 .I DVBABD3="C" S DVBABD3="[COMPLETE]"
183 .I DVBABD3="X" S DVBABD3="[CANCELED BY MAS]"
184 .I DVBABD3="RX" S DVBABD3="[CANCELED BY RO]"
185 .I DVBABD3="T" S DVBABD3="[TRANSFERRED OUT]"
186 .I ZIEN=DVBABD1 D
187 ..S ZMSG(DVBABCNT)=DVBABIEN_"^"_DVBABD2_" "_DVBABD3
188 ..S DVBABCNT=DVBABCNT+1
189 K DVBABCNT,DVBABIEN,ZIEN,DVBABD1,DVBABD2,DVBABD3
190 Q
Note: See TracBrowser for help on using the repository browser.