source: WorldVistAEHR/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBAREN1.m@ 1650

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

initial load of WorldVistAEHR
File size: 4.0 KB
Line 
1DVBAREN1 ;ALB/JLU;NEW 7131 REQ FOR NON-ADMIT VETS;9/20/94
2 ;;2.7;AMIE;**14**;Apr 10, 1995
3 ;this routine contains the logic to search for admissions, appointments, dispositions, and stop codes.
4 ;
5OLD ;this is the main entry point.
6 S DVBANL=0
7 I DVBCHK="A" D A1,COLADM
8 I DVBCHK="N" D N1,COLAPT,COLLOG,COLSTP
9 I DVBCHK="B" D B1,COLADM,COLAPT,COLLOG,COLSTP
10 K DVBAWARN
11 Q
12A1 ;writes header statement for admission dates
13 S VAR(1,0)="0,0,0,2:1,1^The following is a list of Admission dates for "_$P(DFN,U,2)
14 D WR^DVBAUTL4("VAR")
15 K VAR
16 Q
17 ;
18N1 ;writes the header statement for activity dates
19 S VAR(1,0)="0,0,0,2:1,1^The following is a list of activity dates for "_$P(DFN,U,2)
20 D WR^DVBAUTL4("VAR")
21 K VAR
22 Q
23 ;
24B1 ;writes the header statement for both admission and activity dates
25 S VAR(1,0)="0,0,0,2:1,1^The following is a list of Admission and Activity dates for "_$P(DFN,U,2)
26 D WR^DVBAUTL4("VAR")
27 K VAR
28 Q
29 ;
30COLADM ;gathers the admission info. and stores in to the ^TMP global
31 I DVBBDT=0 DO
32 .N X,X1,X2
33 .S X1=0
34 .F X=1:1 S X1=$O(^DGPM("ATID1",+DFN,X1)) Q:'X1 D ADMSET(X1)
35 .Q
36 I DVBBDT>0 DO
37 .N DVBBDT1,DVBEDT1,X,X1,X2
38 .S DVBBDT1=9999999.9999999-(DVBBDT-.0000001)
39 .S DVBEDT1=9999999.9999999-DVBEDT
40 .S X1=DVBEDT1
41 .F X=1:1 S X1=$O(^DGPM("ATID1",+DFN,X1)) Q:'X1!(X1>DVBBDT1) D ADMSET(X1)
42 .Q
43 Q
44 ;
45ADMSET(A) ;starts the process of setting up the ^TMP global
46 ;A is the internal entry number of the admission in the patient movement
47 ;file.
48 N X2,X3
49 S X2=$O(^DGPM("ATID1",+DFN,A,0))
50 S X3=$P(^DGPM(X2,0),U,4)
51 Q:X3']""
52 D SET(A,9999999.9999999-A,"ADMISSION",$P(^DG(405.1,X3,0),U,1),X2)
53 S DVBANL=DVBANL+1
54 Q
55 ;
56COLAPT ;gathers the appointment information
57 I DVBBDT=0 DO
58 .N X,X1,X2
59 .S X1=0
60 .F X=1:1 S X1=$O(^DPT(+DFN,"S",X1)) Q:'X1 D APTSET(X1)
61 .Q
62 I DVBBDT>0 DO
63 .N X,X1
64 .S X1=DVBBDT-.0000001
65 .F X=1:1 S X1=$O(^DPT(+DFN,"S",X1)) Q:'X1!(X1>DVBEDT) D APTSET(X1)
66 .Q
67 Q
68 ;
69APTSET(A) ;begins to set up the ^TMP global for appointments
70 N X2
71 S X2=$P(^DPT(+DFN,"S",A,0),U,1)
72 S X2=$S($D(^SC(X2,0)):$P(^(0),U,1),1:"Unknown")
73 D SET(9999999.9999999-X1,X1,"Appointment",X2)
74 S DVBANL=DVBANL+1
75 Q
76 ;
77COLSTP ;gathers the stop code information
78 N DVBQUERY,DVBDFR,DVBDTO,DVBA,DVBA1,SDOE,SDOE0,DVBZERR
79 S DVBDFR=$S(DVBBDT>0:DVBBDT,1:1),DVBDTO=$S(DVBBDT>0:DVBEDT\1+.99,1:9999999)
80 ;
81 D OPEN^SDQ(.DVBQUERY,"DVBZERR") Q:'$G(DVBQUERY)
82 D INDEX^SDQ(.DVBQUERY,"PATIENT/DATE","SET","DVBZERR")
83 D SCANCB^SDQ(.DVBQUERY,"I $P(SDOE0,U,3) S ^TMP(""DVBENC"",$J,+SDOE0)=$G(^TMP(""DVBENC"",$J,+SDOE0))+1","SET","DVBZERR")
84 D PAT^SDQ(.DVBQUERY,+DFN,"SET","DVBZERR")
85 D DATE^SDQ(.DVBQUERY,DVBDFR,DVBDTO,"SET","DVBZERR")
86 D ACTIVE^SDQ(.DVBQUERY,"TRUE","SET","DVBZERR")
87 K ^TMP("DVBENC",$J)
88 D SCAN^SDQ(.DVBQUERY,"FORWARD","DVBZERR")
89 D CLOSE^SDQ(.DVBQUERY)
90 ;
91 S DVBA=0 F S DVBA=$O(^TMP("DVBENC",$J,DVBA)) Q:'DVBA S DVBA1=^(DVBA) D
92 . D SET(9999999.9999999-DVBA,DVBA,"Stop Code(s)",DVBA1_" Stops")
93 . S DVBANL=DVBANL+1
94 K ^TMP("DVBENC",$J)
95 Q
96 ;
97COLLOG ;gathers the disposition information
98 I DVBBDT>0 DO
99 .N DVBBDT1,DVBEDT1,DVBA,DVBA1,DVBA2,DVBVAR
100 .S DVBBDT1=9999999.9999999-(DVBBDT-.0000001)
101 .S DVBEDT1=9999999.9999999-DVBEDT
102 .S DVBA1=DVBEDT1
103 .F DVBA=1:1 S DVBA1=$O(^DPT(+DFN,"DIS",DVBA1)) Q:'DVBA1!(DVBA1>DVBBDT1) D DISSET(DVBA1)
104 .Q
105 I DVBBDT=0 DO
106 .N DVBA,DVBA1,DVBA2
107 .S DVBA1=0
108 .F DVBA=1:1 S DVBA1=$O(^DPT(+DFN,"DIS",DVBA1)) Q:'DVBA1 D DISSET(DVBA1)
109 .Q
110 Q
111 ;
112DISSET(DVBA2) ;begins to set up the ^TMP with dispositions
113 I '$D(^DPT(+DFN,"DIS",0)),'$D(DVBAWARN) DO
114 .S VAR(1,0)="1,0,0,2:1,0^There is a problem with the Disposition Login information. Contact IRM"
115 .D WR^DVBAUTL4("VAR")
116 .K VAR
117 .D CONTMES^DVBCUTL4
118 .S DVBAWARN=""
119 I $D(^DPT(+DFN,"DIS",0)) DO ;**Bullet Proof
120 .K ^UTILITY("DIQ1",$J)
121 .S DIC="^DPT(",DA=+DFN,DR=1000,DA(2.101)=DVBA2
122 .S DR(2.101)=1,DIQ(0)="E"
123 .D EN^DIQ1
124 .K DIQ,DIC,DR,DA
125 .D SET(DVBA2,9999999.9999999-DVBA2,"Disposition Login",^UTILITY("DIQ1",$J,2.101,DVBA2,1,"E"))
126 .S DVBANL=DVBANL+1
127 Q
128 ;
129SET(IDT,CDT,TYP,FTYP,X2) ;
130 N VAR1
131 S $P(VAR1," ",22)=""
132 S Y=CDT
133 D DD^%DT
134 S ^TMP("DVBA",$J,IDT,TYP)=Y_$E(VAR1,1,23-$L(Y))_TYP_": "_FTYP_"^"_$S($D(X2):X2,1:"")
135 Q
136 ;
Note: See TracBrowser for help on using the repository browser.