source: WorldVistAEHR/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCUTL5.m@ 623

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

initial load of WorldVistAEHR

File size: 4.1 KB
Line 
1DVBCUTL5 ;ALB/GTS-AMIE C&P APPT LINK USER SEL RTNS ; 10/20/94 1:00 PM
2 ;;2.7;AMIE;;Apr 10, 1995
3 ;
4 ;** NOTICE: This routine is part of an implementation of a Nationally
5 ;** Controlled Procedure. Local modifications to this routine
6 ;** are prohibited per VHA Directive 10-93-142
7 ;
8 ;** Version Changes
9 ; 2.7 - New routine (Enhc 13)
10 ;
11REQARY ;** Create Array of 2507's for veteran
12 ;
13 ;** If 2507 status=DVBASTAT, set node in ^TMP("DVBC",$J)
14 ;** ^TMP("DVBC",$J) ordered from newest to oldest 2507
15 ;** The following variables must be KILLed by the calling routine:
16 ;** DVBAMORE, DVBALP, DVBAOUT, DVBADTOT, DVBAPNAM,DVBADA,DVBADFN
17 ;** DVBADT,DVBAORD
18 ;** NOTE: DVBASTAT must be defined before REQARY entry
19 S DVBACNT=0
20 ;
21 ;** If entered from INSUF^DVBCLOG or DVBCMKLK and open
22 ;** exam on current 2507, Set ^TMP
23 F S DVBADA=$O(^DVB(396.3,"B",DVBADFN,DVBADA)) Q:DVBADA="" DO
24 .I $P(^DVB(396.3,DVBADA,0),U,18)=DVBASTAT DO
25 ..S DVBAOPEN=$$OPENCHK(DVBADA) I +DVBAOPEN'>0 K DVBAOPEN
26 ..I '$D(DVBASDPR)!($D(DVBASDPR)&($D(DVBAOPEN))) DO
27 ...K DVBAOPEN
28 ...S DVBADT=$P(^DVB(396.3,DVBADA,0),"^",2),DVBACNT=DVBACNT+1
29 ...S ^TMP("DVBC",$J,9999999.999999-DVBADT,DVBADT,DVBADA)=""
30 Q
31 ;
32REQSEL ;** Select 2507
33 ;
34 ;** Loop ^TMP array, display 2507's in groups of 5
35 ;** ^TMP subscripts:
36 ;** ^TMP("DVBC",$J,9999999.999999-2507 Request date int,
37 ;** Request date int, Request DA)
38 W !!,"Select a 2507 request",!
39 S DVBAORD=""
40 S DVBAPNAM=$P(^DPT(DVBADFN,0),"^",1)
41 F DVBALP=1:1 S DVBAORD=$O(^TMP("DVBC",$J,DVBAORD)) Q:DVBAORD="" DO
42 .S (DVBADT,DVBADA)=""
43 .S DVBADT=$O(^TMP("DVBC",$J,DVBAORD,DVBADT))
44 .S DVBADA=$O(^TMP("DVBC",$J,DVBAORD,DVBADT,DVBADA))
45 .K Y S Y=DVBADT X ^DD("DD")
46 .W !,?5,DVBALP,?8," ",DVBAPNAM,?40," Request date: ",Y
47 .S DVBAMORE=$O(^TMP("DVBC",$J,DVBAORD))
48 .I +DVBAMORE'>0 D SELREQ ;**No more entries
49 .I (+DVBAMORE>0)&(DVBALP#5=0) DO ;**More entries exist, 5 displayed
50 ..W !,"ENTER '^' TO STOP, OR"
51 ..D SELREQ
52 Q
53 ;
54FINDDA ;** Loop ^TMP, get 396.3 DA
55 F DVBALP=1:1:DVBASEL S DVBAORD=$O(^TMP("DVBC",$J,DVBAORD)) DO
56 .S (DVBADT,DVBADA)=""
57 .S DVBADT=$O(^TMP("DVBC",$J,DVBAORD,DVBADT))
58 .S DVBADA=$O(^TMP("DVBC",$J,DVBAORD,DVBADT,DVBADA))
59 Q
60 ;
61SELREQ ;** Select 2507 from ^TMP
62 K DVBAOUT
63 S DIR(0)="NOA^1:"_DVBALP_"^K:X[""."" X"
64 S DIR("?")="Select a 2507 request by entering it's associated number"
65 S DIR("A")="CHOOSE 1-"_DVBALP_": " D ^DIR
66 I $D(DTOUT)!($D(DUOUT)) S DVBAORD="9999999.999999",DVBAOUT=""
67 I '$D(DTOUT)&('$D(DUOUT)) S:+Y>0 DVBAORD="9999999.999999"
68 S:$D(DTOUT) DVBADTOT=""
69 W !
70 K DTOUT,DUOUT,DIR
71 Q
72 ;
73OPENCHK(REQDA) ;** Check for open exam on 2507
74 N LPDA,QVAR
75 S LPDA=""
76 F S LPDA=$O(^DVB(396.4,"C",REQDA,LPDA)) Q:'LPDA!($D(QVAR)) DO
77 .I $P(^DVB(396.4,LPDA,0),U,4)="O" DO
78 ..S:'$D(QVAR) QVAR=LPDA
79 S:'$D(QVAR) QVAR=""
80 Q +QVAR
81 ;
82REQPAT() ;** Select patient who has 2507's
83 S DIC(0)="AEMQ",DIC("A")="Select C&P Veteran Name: ",DIC="^DPT("
84 S DIC("S")="I $D(^DVB(396.3,""B"",+Y))" D ^DIC K DIC
85 Q +Y
86 ;
87CPPATARY(DVBADFN) ;** Set ^TMP of 2507's for vet
88 ;
89 ;** ^TMP array ordered newest to oldest
90 ;** DVBACNT to be killed by calling routine
91 N REQDA,REQDT
92 S DVBACNT=0
93 S REQDA=""
94 F S REQDA=$O(^DVB(396.3,"B",DVBADFN,REQDA)) Q:REQDA="" DO
95 .I +$P(^DVB(396.3,REQDA,0),U,2)>0,($P(^DVB(396.3,REQDA,0),U,18)'="N") DO
96 ..I $P(^DVB(396.3,REQDA,0),U,18)'="" DO
97 ...S REQDT=$P(^DVB(396.3,REQDA,0),"^",2),DVBACNT=DVBACNT+1
98 ...S ^TMP("DVBC",$J,9999999.999999-REQDT,REQDT,REQDA)=""
99 Q
100 ;
101NO2507 ;** 2507 not selected, error
102 S DIR("A",1)="You have not selected a 2507 request to link a C&P appointment to."
103 S DIR("A",2)="This is required to continue processing with the AMIE link management option."
104 S DIR("A",3)=" "
105 S DIR(0)="FAO^1:1",DIR("A")="Hit Return to continue." D ^DIR K DIR,X,Y
106 Q
107 ;
108SDEVTSPC(DVBAPCE) ;**Return piece of 'S' node in Sched event
109 N DVBASPCV
110 S DVBASPCV=""
111 S:($D(^TMP("SDEVT",$J,SDHDL,1,"DPT",0,"AFTER"))) DVBASPCV=$P(^TMP("SDEVT",$J,SDHDL,1,"DPT",0,"AFTER"),U,DVBAPCE)
112 Q DVBASPCV
113 ;
114SDEVTXST() ;** Check ^TMP("SDEVT",$J) existence
115 Q $D(^TMP("SDEVT",$J,SDHDL,1,"DPT",0,"AFTER"))
116 ;
117SDORGST() ;** Return value of SD Event originating process
118 N DVBAVAR
119 S DVBAVAR=""
120 Q $O(^TMP("SDEVT",$J,SDHDL,DVBAVAR))
121 ;
Note: See TracBrowser for help on using the repository browser.