source: FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCULAP.m

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

initial load of FOIAVistA 6/30/08 version

File size: 4.2 KB
Line 
1DVBCULAP ;ALB/GTS-AMIE UNLINKED APPT REPORT ; 10/19/94 3:30 PM
2 ;;2.7;AMIE;;Apr 10, 1995
3 ;
4 ;** Version Changes
5 ; 2.7 - New routine (Enhc 13)
6 ;
7 ;** DVBCULAP run if 2507 Integrity Report Status parameter not OFF,
8 ;** ^TMP("DVBA",$J) global is defined, C&P Report Parameter is ON
9 ;
10 ;** Variable Descriptions
11 ;** ^TMP("DVBA",$J,NAME,DFN) must be defined for vets to be reported
12 ;** prior to executing this routine. Global KILLed by calling rtn
13 ;** ^TMP("DVBC",$J,NAME,DFN) will be equal to:
14 ;** ^ exam date (ext) ^ date appt made ^ clerk ^ Appt Status (ext)
15 ;
16EN N TMPDA,STRTDT,PARAMDA,BEGDT,TODAYDT,SITE,LPCNT,SSN
17 N DVBAPNAM,DVBADFN
18 S SITE=$$SITE^DVBCUTL4
19 S (DVBAPNAM,DVBADFN)=""
20 S PARAMDA=0
21 S PARAMDA=$O(^DVB(396.1,PARAMDA))
22 D NOW^%DTC
23 S Y=X X ^DD("DD") S TODAYDT=Y K Y
24 ;
25 ;**Only appts for date previous to report date by number of days in
26 ;** AMIE Site Parameter File - Days to Keep 2507 History
27 S X2=-(+$P(^DVB(396.1,PARAMDA,0),U,11)) S X1=X K X
28 D C^%DTC
29 S BEGDT=X-.0001,TMPDA=0 K X,X1,X2,STATUS,STATVAR
30 ;
31 ;** Create ^TMP("DVBC",$J) global entry for C&P appt in date range
32 F S DVBAPNAM=$O(^TMP("DVBA",$J,DVBAPNAM)) Q:DVBAPNAM="" DO
33 .F S DVBADFN=$O(^TMP("DVBA",$J,DVBAPNAM,DVBADFN)) Q:DVBADFN="" DO
34 ..S STRTDT=BEGDT
35 ..F S STRTDT=$O(^DPT(DVBADFN,"S",STRTDT)) Q:STRTDT="" DO
36 ...I $P(^DPT(DVBADFN,"S",STRTDT,0),U,16)=1 DO ;**Appt is type C&P
37 ....S TMPDA=TMPDA+1
38 ....S DA=DVBADFN,DA(2.98)=STRTDT,DR="1900",DR(2.98)="19;20",DIC=2
39 ....S DIQ="DVBAARY"
40 ....K ^UTILITY("DIQ1",$J)
41 ....D EN^DIQ1
42 ....K ^UTILITY("DIQ1",$J)
43 ....S Y=STRTDT X ^DD("DD")
44 ....S OUTDT=Y
45 ....S STATVAR=$$STATUS^SDAM1(DVBADFN,STRTDT,$P(^DPT(DVBADFN,"S",STRTDT,0),U,1),^DPT(DVBADFN,"S",STRTDT,0))
46 ....S STATUS=$P(STATVAR,";",3)
47 ....I DVBAARY(2.98,STRTDT,20)="" DO ;**If info in Hosp Loc file (#44)
48 .....K DA,DR,DIC,Y
49 .....S DIC="^SC("_$P(^DPT(DVBADFN,"S",STRTDT,0),U,1)_",""S"","_STRTDT_",1,"
50 .....S DIC(0)="MQ",X=DVBADFN
51 .....D ^DIC S SCIEN=+Y
52 .....K Y,DA,DR,DIC,DIQ,^UTILITY("DIQ1",$J)
53 .....S DA=$P(^DPT(DVBADFN,"S",STRTDT,0),U,1),DIC="^SC("
54 .....S DA(44.001)=STRTDT,DA(44.003)=SCIEN
55 .....S DR="1900",DR(44.001)="2",DR(44.003)="7;8"
56 .....S DIQ="DVBAARY"
57 .....D EN^DIQ1
58 .....K ^UTILITY("DIQ1",$J)
59 .....S ^TMP("DVBC",$J,DVBAPNAM,DVBADFN,TMPDA)=OUTDT_"^"_$S($D(DVBAARY(44.003,SCIEN,7)):DVBAARY(44.003,SCIEN,8)_"^"_DVBAARY(44.003,SCIEN,7)_"^"_STATUS,'$D(DVBAARY(44.003,SCIEN,7)):"BAD Hospital Location record - Contact IRM")
60 .....K SCIEN
61 ....I DVBAARY(2.98,STRTDT,20)'="" DO ;**If info in DPT "S" node
62 .....S ^TMP("DVBC",$J,DVBAPNAM,DVBADFN,TMPDA)=OUTDT_"^"_DVBAARY(2.98,STRTDT,20)_"^"_DVBAARY(2.98,STRTDT,19)_"^"_STATUS
63 ....K DVBAARY(2.98),Y,STATUS,STATVAR
64 ..K DVBAARY(44.003)
65 I '$D(DVBCQUIT) D:$D(^TMP("DVBC",$J)) RPTHD
66 S (DVBADFN,DVBAPNAM,DVBANPGE)=""
67 K DVBCOUT
68 S:$D(DVBCQUIT) DVBCOUT=""
69 F S DVBAPNAM=$O(^TMP("DVBC",$J,DVBAPNAM)) Q:(DVBAPNAM=""!($D(DVBCOUT))) DO
70 .I $Y>(IOSL-13) DO
71 ..I IOST?1"C-".E DO
72 ...D PAUSE^DVBCUTL4
73 ...S:+Y=0 DVBCOUT=""
74 ..D:'$D(DVBCOUT) RPTHD
75 ..S DVBANPGE=""
76 .I '$D(DVBCOUT) DO
77 ..S DVBADFN=""
78 ..F S DVBADFN=$O(^TMP("DVBC",$J,DVBAPNAM,DVBADFN)) Q:DVBADFN=""!($D(DVBCOUT)) DO
79 ...I $Y>(IOSL-7) DO
80 ....I IOST?1"C-".E DO
81 .....D PAUSE^DVBCUTL4
82 .....S:+Y=0 DVBCOUT=""
83 ....D:'$D(DVBCOUT) RPTHD
84 ....S DVBANPGE=""
85 ...I '$D(DVBCOUT) DO
86 ....S SSN=$P(^DPT(DVBADFN,0),U,9)
87 ....K DVBCSSNO
88 ....D SSNSHRT^DVBCUTIL
89 ....D RPTSUBHD
90 ....S TMPDA=""
91 ....F S TMPDA=$O(^TMP("DVBC",$J,DVBAPNAM,DVBADFN,TMPDA)) Q:TMPDA=""!($D(DVBCOUT)) DO
92 .....I $Y>(IOSL-4) DO
93 ......I IOST?1"C-".E DO
94 .......D PAUSE^DVBCUTL4
95 .......S:+Y=0 DVBCOUT=""
96 ......S DVBANPGE=""
97 ......D:'$D(DVBCOUT) RPTHD,RPTSUBHD
98 .....I '$D(DVBCOUT) DO
99 ......W !,$P(^TMP("DVBC",$J,DVBAPNAM,DVBADFN,TMPDA),U,1)
100 ......W ?25,$P(^TMP("DVBC",$J,DVBAPNAM,DVBADFN,TMPDA),U,2)
101 ......W ?50,$P(^TMP("DVBC",$J,DVBAPNAM,DVBADFN,TMPDA),U,3)
102 I (IOST?1"C-".E),('$D(DVBCOUT)&($D(^TMP("DVBC",$J)))) D PAUSE^DVBCUTL4
103 KILL ^TMP("DVBC",$J),DVBCSSNO,DVBCOUT,OUTDT,DVBANPGE,DVBAARY(44.003)
104 Q
105 ;
106RPTHD ;
107 W @IOF
108 N DVBALN
109 W !,?(80-$L(SITE)\2),SITE
110 W !!,"AMIE appointment integrity report"
111 W !,"Date: ",TODAYDT
112 S $P(DVBALN,"-",80)=""
113 W !,DVBALN
114 Q
115 ;
116RPTSUBHD ;
117 W:'$D(DVBANPGE) !!
118 W !,"Veteran: ",DVBAPNAM,?50,"SSN: ",DVBCSSNO
119 W !!,"Appt Date",?25,"Date Appt Made",?50,"Clerk"
120 W !
121 K DVBANPGE
122 Q
Note: See TracBrowser for help on using the repository browser.