source: FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCUTA2.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 4.3 KB
Line 
1DVBCUTA2 ;ALB/GTS-AMIE C&P UTILITY ROUTINE A-2 ; 2/8/95 11:15 AM
2 ;;2.7;AMIE;;Apr 10, 1995
3 ;
4 ;** Version Changes
5 ; 2.7 - New routine (Enhc 15)
6 ;
7INSUFXM ;** Insufficient exam information entry (Called from DVBCREDT)
8 K DIR,Y
9 N EXMNM,XMSTAT,XMDA,REQDA
10 S REQDA=SAVEDA
11 I $D(^DVB(396.3,REQDA,5)),NODE5=^DVB(396.3,REQDA,5) DO
12 .W !
13 .D XMQS
14 .I +Y=1 DO
15 ..K DIR,Y
16 ..K DTOUT,DUOUT
17 ..F XMDA=0:0 S XMDA=$O(^DVB(396.4,"C",REQDA,XMDA)) Q:(XMDA=""!($D(DTOUT))) D XMUPDT
18 .K DIR,Y
19 I $D(^DVB(396.3,REQDA,5)),(NODE5'=^DVB(396.3,REQDA,5)) DO
20 .D EXMEDIT
21 .I $D(XMEDT) DO
22 ..K DTOUT
23 ..D SAVEXAM ;**Save exam info in case time out
24 ..F XMDA=0:0 S XMDA=$O(^DVB(396.4,"C",REQDA,XMDA)) Q:(XMDA=""!($D(DTOUT))) D XMUPDT
25 ..I $D(DTOUT) D RESTLINK,RESTXAMS ;**Restore link and exam info
26 .I '$D(XMEDT) DO ;**Update original provider automatically
27 ..F XMDA=0:0 S XMDA=$O(^DVB(396.4,"C",REQDA,XMDA)) Q:XMDA="" D PROVUP
28 K Y,^TMP($J,"NEW"),XMEDT,^TMP("DVBC",$J,396.4)
29 Q
30 ;
31XMUPDT ;** Update exam insuf info
32 W @IOF
33 S EXMNM=$P(^DVB(396.6,$P(^DVB(396.4,XMDA,0),U,3),0),U,1)
34 S ^TMP($J,"NEW",EXMNM)=$P(^DVB(396.4,XMDA,0),U,3)
35 S XMSTAT=$P(^DVB(396.4,XMDA,0),U,4),Y=XMDA ;**Set var's for INSXM
36 N DVBAINDA S DVBAINDA=$P(^DVB(396.3,REQDA,5),U,1)
37 D:(XMSTAT'["X"&(XMSTAT'="T")) INSXM^DVBCUTA1 ;**Update exam info
38 Q
39 ;
40PROVUP ;** Auto update original provider
41 K DIE,Y,DR,DA
42 N DVBAXMTP,DVBAPROV,DVBAORXM,DVBACMND,DVBAINDA
43 S DVBAINDA=+$P(^DVB(396.3,REQDA,5),U,1)
44 S DVBAXMTP=$P(^DVB(396.4,XMDA,0),U,3),DVBAORXM="",DVBAPROV=""
45 S DVBACMND="S DVBAORXM=$O(^DVB(396.4,""ARQ"_DVBAINDA_""","_DVBAXMTP_",DVBAORXM))"
46 N XREF S XREF="ARQ"_DVBAINDA
47 I $D(^DVB(396.4,XREF,DVBAXMTP)) X DVBACMND ;**Return insuff exam IEN
48 S:+DVBAORXM>0 DVBAPROV=$P(^DVB(396.4,DVBAORXM,0),U,7)
49 I DVBAPROV="" DO
50 .S DVBAPROV="Unknown" ;**Bad 'ARQ' X-Ref
51 K DVBADMNM
52 I +DVBAORXM>0,($D(^DVB(396.4,DVBAORXM,"TRAN"))) DO
53 .S DVBADMNM=$P(^DIC(4.2,+$P(^DVB(396.4,DVBAORXM,"TRAN"),U,3),0),U,1)
54 .S DVBADMNM=$P(DVBADMNM,".",1)
55 S:$D(DVBADMNM) DVBAPROV=DVBAPROV_" at "_DVBADMNM
56 S DIE="^DVB(396.4,",DR=".12////^S X=DVBAPROV",DA=XMDA
57 D ^DIE K DIE,DR,DA
58 Q
59 ;
60RESTLINK ;** Restore 2507 link info (Called from ^DVBCREDT & INSUFXM)
61 N LINKDA,DAYS
62 S LINKDA=$P(NODE5,U,1)
63 S DAYS=$P(NODE5,U,2)
64 S:LINKDA="" LINKDA="@"
65 S:DAYS="" DAYS="@"
66 K DA,DR,DIE
67 S DIE="^DVB(396.3,"
68 S DA=REQDA,DR="44////^S X=LINKDA;45////^S X=DAYS"
69 D ^DIE
70 K DA,DR,DIE
71 S TVAR(1,0)="1,3,0,2:1,0^All exams must be reviewed....Insufficient link and info not updated!"
72 D WR^DVBAUTL4("TVAR")
73 K TVAR
74 D CONTMES^DVBCUTL4
75 Q
76 ;
77EXMEDIT ;** Ask user to edit exams
78 I '$D(UPDT2507)!((+$P(^DVB(396.3,REQDA,5),U,1)>0)&($D(UPDT2507))) DO
79 .D XMQS
80 .S:+Y=1 XMEDT=""
81 I (+$P(^DVB(396.3,REQDA,5),U,1)'>0)&($D(UPDT2507)) DO
82 .S TVAR(1,0)="1,3,0,2:1,0^Review exam info for a new Original Provider."
83 .D WR^DVBAUTL4("TVAR")
84 .K TVAR
85 .S XMEDT=""
86 .D CONTMES^DVBCUTL4
87 Q
88 ;
89XMQS ;** Edit exams?
90 S DIR(0)="Y^AO",DIR("A")="Do you want to edit the insufficient information for the exams"
91 S DIR("?",1)="Enter Yes to edit Remarks, Insufficient Reason and Original Providor (when"
92 S DIR("?")=" appropriate). Enter No to keep the current information."
93 S DIR("B")="NO" D ^DIR
94 Q
95 ;
96SAVEXAM ;** Save exam info prior to edit
97 N REMDA,XMDA
98 F XMDA=0:0 S XMDA=$O(^DVB(396.4,"C",REQDA,XMDA)) Q:XMDA="" DO
99 .S ^TMP("DVBC",$J,396.4,XMDA,0)=$P(^DVB(396.4,XMDA,0),U,11)_"^"_$P(^DVB(396.4,XMDA,0),U,12)
100 .F REMDA=0:0 S REMDA=$O(^DVB(396.4,XMDA,"INREM",REMDA)) Q:REMDA="" DO
101 ..S ^TMP("DVBC",$J,396.4,XMDA,"INREM",REMDA,0)=^DVB(396.4,XMDA,"INREM",REMDA,0)
102 Q
103 ;
104RESTXAMS ;** Restore exam information (Called from INSUFXM)
105 N REMDA,XMDA,REASDA,PROV,REMARK,LNCNT,XMSTAT
106 F XMDA=0:0 S XMDA=$O(^DVB(396.4,"C",REQDA,XMDA)) Q:XMDA="" DO
107 .S XMSTAT=$P(^DVB(396.4,XMDA,0),U,4)
108 .I (XMSTAT'["X")&(XMSTAT'["T") DO
109 ..S REASDA=$P(^TMP("DVBC",$J,396.4,XMDA,0),U,1)
110 ..S PROV=$P(^TMP("DVBC",$J,396.4,XMDA,0),U,2)
111 ..K DIE,DR,DA
112 ..S DIE="^DVB(396.4,",DR=".11////^S X=REASDA;.12////^S X=PROV;80////@",DA=XMDA
113 ..D ^DIE
114 ..S LNCNT=0
115 ..S:'$D(^DVB(396.4,XMDA,"INREM",0)) ^DVB(396.4,XMDA,"INREM",0)="^^0^0^"_DT_"^"
116 ..F REMDA=0:0 S REMDA=$O(^TMP("DVBC",$J,396.4,XMDA,"INREM",REMDA)) Q:REMDA="" DO
117 ...S REMARK=^TMP("DVBC",$J,396.4,XMDA,"INREM",REMDA,0)
118 ...S LNCNT=LNCNT+1
119 ...S ^DVB(396.4,XMDA,"INREM",REMDA,0)=REMARK
120 ..S ^DVB(396.4,XMDA,"INREM",0)="^^"_LNCNT_"^"_LNCNT_"^"_DT_"^"
121 Q
Note: See TracBrowser for help on using the repository browser.