source: FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBADXFR.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 4.1 KB
Line 
1DVBADXFR ;ALB/GTS-AMIE 7131 DIVISIONAL TRANSFER RTN ; 12/6/94 2:00 PM
2 ;;2.7;AMIE;;Apr 10, 1995
3 ;
4MAIN ;**Loop to select and update 7131 report divisions
5 F DO I $D(DTOUT)!($D(DUOUT)!($D(DVBAOUT))) Q ;**QUIT top 'For' loop
6 .D HOME^%ZIS
7 .W @IOF
8 .W !!,?5,"7131 Divisional Transfer",!!
9 .S REQDA=$$SEL7131^DVBAUTL7()
10 .S:+REQDA'>0 DVBAOUT=""
11 .I +REQDA>0 DO
12 ..D INITIAL,REQVARS
13 ..D INITRPT^DVBAUTL7(REQDA)
14 ..K DTOUT,DUOUT,DVBAOUT
15 ..F DO I $D(DTOUT)!($D(DUOUT)!($D(DVBAOUT))) Q ;**QUIT 'For' loop
16 ...K NODIV
17 ...D DRAW
18 ...D READ I $D(DTOUT)!($D(DUOUT)!($D(DVBAOUT))) Q ;**QUIT 'For' loop
19 ...D DIVSEL I $D(DTOUT)!($D(DUOUT)!($D(DVBAOUT))) Q ;**QUIT 'For' loop
20 ...D:'$D(NODIV) ADJ
21 ..I '$D(DTOUT)&('$D(DUOUT)) D FILE^DVBAUTL7
22 ..D EXITLP
23 K DVBAOUT,REQDA,DA,DIE,DIR,DR,DTOUT,DUOUT
24 W @IOF
25 Q
26 ;
27EXITLP K A,DA,DIE,DIR,DR,DTOUT,DUOUT,DVBADSCH,DVBAER,DVBAHD21,DVBALN,DVBAOUT
28 K FLDDIV,FLDDTE,REQDIV,DVBARPT,DVBATDT,DVBATITL,DVBAX,X,Z,DVBAP,DVBAO
29 K REQDTE,DVBARPT,REQDA,DVBCSSNO,SSN,HNAME,PNAM,DVBREQDT,DFN,RPTVAR
30 K NDIVIEN,NDIVNAME,CNUM,NODIV
31 Q
32 ;
33INITIAL ;**initialize general variables
34 S $P(DVBALN,"-",80)=""
35 S DVBATITL="7131 Divisional Transfer"
36 S X="NOW",%DT="ST"
37 D ^%DT
38 X ^DD("DD")
39 S DVBATDT=Y
40 S HNAME=$$SITE^DVBCUTL4()
41 K X,Y,%DT
42 Q
43 ;
44REQVARS ;**Set variables unique to 7131
45 S DVBREQDT=$P(^DVB(396,REQDA,0),U,4)
46 I $P(^DVB(396,REQDA,2),U,10)="L" D ACT
47 I $P(^DVB(396,REQDA,2),U,10)="A" D ADM
48 S DFN=$P(^DVB(396,REQDA,0),U,1)
49 S PNAM=$P(^DPT(DFN,0),U,1),SSN=$P(^DPT(+DFN,0),U,9)
50 S CNUM=$S($D(^DPT(+DFN,.31)):$P(^(.31),U,3),1:"Unknown")
51 D SSNOUT^DVBCUTIL
52 S SSN=DVBCSSNO
53 Q
54 ;
55ADM ;**Set up admission date and discharge variables
56 S Y=DVBREQDT
57 D DD^%DT
58 S DVBAHD21="Admission Date: "_Y
59 K Y
60 Q
61 ;
62ACT ;**Set up activity date variable
63 S Y=DVBREQDT
64 D DD^%DT
65 S DVBAHD21="Activity Date: "_Y
66 K Y
67 Q
68 ;
69DRAW ;** Output Division screen
70 I IOST?1"C-".E W @IOF
71 W "Information Request Form"
72 W ?35,HNAME
73 W ?59,DVBATDT
74 W !,DVBALN
75 W !,"Patient: "
76 W PNAM
77 W ?54,"SSN: "
78 W SSN
79 W !,"Claim #: ",CNUM,!
80 W DVBAHD21
81 W !!,?9,"Report",?37,"Selected",?48,"Status",?58,"Division"
82 W !,DVBALN
83 F DVBAX=0:0 S DVBAX=$O(DVBARPT(DVBAX)) Q:'DVBAX D DRAW1
84 W !,DVBALN
85 Q
86 ;
87DRAW1 ;** Output a report to the screen
88 W !,DVBAX
89 W ?3,$P(DVBARPT(DVBAX),U,1)
90 W ?40,$S($P(DVBARPT(DVBAX),U,2)["Y":"YES",1:"NO")
91 W ?48,$S($P(DVBARPT(DVBAX),U,3)="C":"Completed",$P(DVBARPT(DVBAX),U,3)="P":"Pending",1:"")
92 W ?58,$E($P(DVBARPT(DVBAX),U,4),1,20)
93 Q
94 ;
95READ ;** Read selected report
96 S DIR(0)="LAO^1:11^K:X[""."" X"
97 S DIR("A")="Select Report(s) to Transfer: "
98 S DIR("?",1)="Select a number or range of numbers from 1 to 10 (1,3,5 or 2-4,8). You will"
99 S DIR("?",2)="then be asked to select a division to transfer the report(s) to. After a"
100 S DIR("?")="division is selected, the new division will display next to the report(s)."
101 D ^DIR
102 I $D(DUOUT)!($D(DTOUT)) Q
103 I 'Y S DVBAOUT="" ;**User hit Return at report prompt
104 S:$D(Y) RPTVAR=Y
105 Q
106 ;
107DIVSEL ;** Select a division to transfer to (Division must be in AMIE Site
108 ;** Parameter File)
109 N PARAMDA
110 S PARAMDA=$$IFNPAR^DVBAUTL3()
111 D:PARAMDA'>0 PARAMERR
112 I PARAMDA>0 DO
113 .S DIC(0)="AEMQ"
114 .S DIC("A")="Select a Division to Transfer to: "
115 .S DIC="^DVB(396.1,PARAMDA,2,"
116 .D ^DIC
117 .S:+Y>0 NDIVIEN=$P(^DVB(396.1,PARAMDA,2,+Y,0),U,1)
118 .S:+Y>0 NDIVNAME=$P(^DG(40.8,NDIVIEN,0),U,1)
119 .S:+Y'>0 NODIV=""
120 .K DIC,Y
121 Q
122 ;
123PARAMERR ;** Error if the AMIE Site Parameter file has a problem
124 W *7,!,"The AMIE Site Parameter File is not set up properly."
125 W !,"Contact the Medical Center's IRM department."
126 W !,?30,"<Return> to continue."
127 R Z:DTIME
128 S DVBAOUT=""
129 Q
130 ;
131ADJ ;** Adjust local array DVBARPT(#)
132 K DVBAER
133 N X,A
134 F X=1:1:11 S A=$P(RPTVAR,",",X) Q:'A D CHECK
135 D:'$D(DVBAER) CHNG
136 K Y
137 Q
138 ;
139CHECK ;** Check for X-fer of report with status '= Pending
140 I $P(DVBARPT(A),U,3)'="P" DO:'$D(DVBAER) S DVBAER=1 Q
141 .W *7,!,"You have selected a report with a status other than Pending."
142 .W !,"All reports selected for transfer must be Pending."
143 .W !,?30,"<Return> to continue."
144 .R Z:DTIME
145 .Q
146 Q
147 ;
148CHNG ;** Update local array DVBARPT(#)
149 F X=1:1:11 S A=$P(RPTVAR,",",X) Q:'A DO
150 .I $P(DVBARPT(A),U,3)="P" DO
151 ..S $P(DVBARPT(A),U,4)=NDIVNAME
152 ..S $P(DVBARPT(A),U,5)=NDIVIEN
153 Q
Note: See TracBrowser for help on using the repository browser.