source: WorldVistAEHR/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCUTA3.m@ 1259

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

initial load of WorldVistAEHR

File size: 4.0 KB
Line 
1DVBCUTA3 ;ALB/GTS-AMIE C&P UTILITY ROUTINE A-3 ; 2/10/95 11:15 AM
2 ;;2.7;AMIE;;Apr 10, 1995
3 ;
4 ;** Version Changes
5 ; 2.7 - New routine (Enhc 15)
6 ;
7INRSLK() ;** Lookup insufficient reason
8 N REASVAR,DVBAOUT,REASIN
9 S REASVAR=-1,REASIN=""
10 K DTOUT,DUOUT
11 F Q:($D(DTOUT)!(+REASVAR>0)!($D(DVBAOUT))) DO
12 .I '$D(DVBAXMDA) DO
13 ..R !,"INSUFFICIENT REASON: ",REASIN:DTIME
14 ..S:'$T DVBAOUT=""
15 .I $D(DVBAXMDA),(+DVBAXMDA'>0) DO
16 ..R !,"INSUFFICIENT REASON: ",REASIN:DTIME
17 ..S:'$T DVBAOUT=""
18 .I $D(DVBAXMDA),(+DVBAXMDA>0&(+$P(^DVB(396.4,DVBAXMDA,0),U,11)'>0)) DO
19 ..R !,"INSUFFICIENT REASON: ",REASIN:DTIME
20 ..S:'$T DVBAOUT=""
21 .I $D(DVBAXMDA),(+DVBAXMDA>0&(+$P(^DVB(396.4,DVBAXMDA,0),U,11)>0)) DO
22 ..W !,"INSUFFICIENT REASON: "
23 ..S:'$T DVBAOUT=""
24 ..I +$P(^DVB(396.4,DVBAXMDA,0),U,11)>0 DO
25 ...W $P(^DVB(396.94,$P(^DVB(396.4,DVBAXMDA,0),U,11),0),U,1)_"//"
26 ..R REASIN:DTIME
27 ..S:'$T DVBAOUT=""
28 ..I '$D(DVBAOUT),(REASIN="") S REASIN=$P(^DVB(396.94,$P(^DVB(396.4,DVBAXMDA,0),U,11),0),U,1)
29 .I REASIN="^" DO
30 ..S TVAR(1,0)="0,0,0,0,0^NOT ALLOWED"
31 ..D WR^DVBAUTL4("TVAR")
32 ..K TVAR
33 .I '$D(DVBAOUT),(REASIN="") S REASIN="^"
34 .I REASIN="^" DO
35 ..S TVAR(1,0)="0,0,0,0,0^??"
36 ..S TVAR(2,0)="0,5,0,1,0^Enter the insufficient reason this exam is being returned."
37 ..S TVAR(3,0)="0,1,0,1,0^ANSWER WITH 2507 INSUFFICIENT REASONS INSUFFICIENT CODE"
38 ..D WR^DVBAUTL4("TVAR")
39 ..K TVAR
40 .I REASIN="?" DO
41 ..K DIR S DIR(0)="YAO"
42 ..S DIR("A",1)=" Enter the insufficient reason this exam is being returned. "
43 ..S DIR("A",2)=" ANSWER WITH 2507 INSUFFICIENT REASONS INSUFFICIENT CODE"
44 ..S DIR("A")=" DO YOU WANT THE ENTIRE 13-ENTRY 2507 INSUFFICIENT REASONS LIST? "
45 ..D ^DIR
46 ..D:+Y=1 RESHELP
47 ..K Y,DIR
48 .I REASIN["??" DO
49 ..S TVAR(1,0)="0,0,0,1,0^This field contains a pointer to the Insufficient Reason file (396.94)."
50 ..D WR^DVBAUTL4("TVAR")
51 ..K TVAR
52 ..D RESHELP
53 .I REASIN'="^",(REASIN'["?") DO
54 ..S DIC="^DVB(396.94,",X=REASIN,DIC(0)="MQE"
55 ..D ^DIC
56 ..S REASVAR=Y
57 ..K DIC,X,Y
58 S:($D(DTOUT)!($D(DVBAOUT))) REASVAR=-1
59 Q REASVAR
60 ;
61RESHELP ;** Help for insufficient reasons
62 N LPVAR
63 S TVAR(1,0)="0,0,0,2,0^CHOOSE FROM:"
64 D WR^DVBAUTL4("TVAR")
65 K TVAR
66 F LPVAR=0:0 S LPVAR=$O(^DVB(396.94,LPVAR)) Q:+LPVAR=0 DO
67 .S TVAR(1,0)="0,3:0,0,1,0^"_$P(^DVB(396.94,LPVAR,0),U,1)
68 .D WR^DVBAUTL4("TVAR")
69 .K TVAR
70 W !
71 Q
72 ;
73LNKLIST ;** List links for user
74 I '$D(TMP("DVBC LINK")) DO
75 .S TVAR(1,0)="0,0,0,1,0^There are no links to this 2507 request."
76 .D WR^DVBAUTL4("TVAR")
77 .K TVAR
78 .D CONTMES^DVBCUTL4
79 I $D(TMP("DVBC LINK")) DO
80 .N DVBAMORE
81 .W !,?2,"Current Appointment Links",!
82 .W !,?1,"Initial Appt",?21,"Clock Stop Appt",?41,"Current Appt",?61,"Clinic"
83 .S ARYDA=""
84 .N GETOUT
85 .F ARYDA=1:1 Q:('$D(TMP("DVBC LINK",ARYDA))!($D(GETOUT))) DO
86 ..S SELDA=""
87 ..S SELDA=$O(TMP("DVBC LINK",ARYDA,SELDA))
88 ..W !,?1,$P(TMP("DVBC LINK",ARYDA,SELDA),U,1)
89 ..W ?21,$P(TMP("DVBC LINK",ARYDA,SELDA),U,2),?41,$P(TMP("DVBC LINK",ARYDA,SELDA),U,3)
90 ..W ?61,$E($P(TMP("DVBC LINK",ARYDA,SELDA),U,4),1,18)
91 ..S DVBAMORE=$O(TMP("DVBC LINK",ARYDA))
92 ..I (+DVBAMORE'>0)!(+DVBAMORE>0&(ARYDA#5=0)) DO
93 ...K DIR
94 ...S DIR(0)="F,O^^",DIR("A")="Enter [Return] to continue or ""^"" to exit"
95 ...K GETOUT D ^DIR S:$D(DTOUT)!($D(DUOUT)) GETOUT=1
96 ...I '$D(GETOUT) W ! K DIR,DIRUT,X
97 .K TMP("DVBC LINK"),ARYDA,SELDA,DIR,X
98 Q
99 ;
100LNKARY(REQDA,DVBADFN) ;** Set up the link array (In TMP local)
101 N LKDA,ARYDA
102 S LKDA="",ARYDA=0
103 F S LKDA=$O(^DVB(396.95,"AR",REQDA,LKDA)) Q:+LKDA=0 DO
104 .S ARYDA=ARYDA+1
105 .S Y=$P(^DVB(396.95,LKDA,0),U,1) X ^DD("DD")
106 .S TMP("DVBC LINK",ARYDA,LKDA)=Y K Y
107 .S Y=$P(^DVB(396.95,LKDA,0),U,2) X ^DD("DD")
108 .S TMP("DVBC LINK",ARYDA,LKDA)=TMP("DVBC LINK",ARYDA,LKDA)_"^"_Y K Y
109 .S Y=$P(^DVB(396.95,LKDA,0),U,3) X ^DD("DD")
110 .S TMP("DVBC LINK",ARYDA,LKDA)=TMP("DVBC LINK",ARYDA,LKDA)_"^"_Y K Y
111 .S DA=DVBADFN,DA(2.98)=$P(^DVB(396.95,LKDA,0),U,3),DR="1900",DR(2.98)=".01",DIC=2
112 .S DIQ="DVBACLIN" K ^UTILITY("DIQ",$J)
113 .D EN^DIQ1 K ^UTILITY("DIQ",$J)
114 .S TMP("DVBC LINK",ARYDA,LKDA)=TMP("DVBC LINK",ARYDA,LKDA)_"^"_DVBACLIN(2.98,$P(^DVB(396.95,LKDA,0),U,3),.01)
115 .K DVBACLIN
116 Q
Note: See TracBrowser for help on using the repository browser.