source: FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBAUTL2.m@ 868

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

initial load of FOIAVistA 6/30/08 version

File size: 3.9 KB
Line 
1DVBAUTL2 ;ALB/GTS-557/THM-AMIE UTILITIES ;24 AUG 89
2 ;;2.7;AMIE;;Apr 10, 1995
3 ;
4REOPEN ;used by DVBAREG1 and DVBAREN1 only to re-log 7131s
5 W *7,!!,"Are you sure you want to DELETE the existing 7131 for this date",!,"and log a NEW one" S %=2 D YN^DICN ;must be finalized to reopen
6 I $D(%Y),%Y["?" W !!,"Enter Y to delete the finalized 7131 request that",!,"exists for this date and log a new one.",!!,"Enter N to leave the existing 7131 as is.",! G REOPEN
7 I %'=1 S ONFILE=1 K OLDDA,%,%Y Q
8 I '$D(DVBREQDT) W *7,!!,"Activity or admission date is missing ! Cannot reopen.",!! H 3 S ONFILE=1 Q
9 K DIC("S"),DVBAEDT
10 S OLDY=Y,OLDDA=DA,DIK="^DVB(396," D WAIT^DICD,^DIK S (DA,DINUM)=OLDDA,X=+DFN K DD,DO S DLAYGO=396,DIC(0)="EQLM",DIC="^DVB(396," D FILE^DICN ;use same IFN
11 S DR="1////"_CNUM_";2////"_SSN_";3////"_DVBREQDT_";23////"_DT_";24////"_DT_";27////"_LOC_";28////"_OPER_";30////"_DVBDOC,DIE=DIC D ^DIE K DLAYGO
12 W !!,*7,"You may now enter a new 7131 for this date.",!! H 2
13 S Y=OLDY
14 K OLDDA,%,%Y
15 Q
16 ;
17NOPARM ;check for AMIE parameter setup
18 I '$D(^DVB(396.1,1,0)) W !!,*7,"No site parameters have been setup in file 396.1.",!,"You must do this before running any reports.",!! S DVBAQUIT=1 H 3
19 Q
20 ;
21ADTYPE W !!,"Do you want (A)&A, (P)ension, (S)ervice-connected, or AL(L) discharges ? S// " R ADTYPE:DTIME I '$T!(ADTYPE=U) S DVBAQUIT=1 Q
22 S X=ADTYPE X ^%ZOSF("UPPERCASE") S ADTYPE=Y
23 S:ADTYPE="" ADTYPE="S" I ADTYPE'?1"A"&(ADTYPE'?1"S")&(ADTYPE'?1"L")&(ADTYPE'?1"P") W *7,!!,"Must be A for A&A, P for Pension, S for Service-connected, or L for All" G ADTYPE
24 S HEAD=$S(ADTYPE="P":"PENSION",ADTYPE="A":"A&A",ADTYPE="S":"SERVICE-CONNECTED",ADTYPE="L":"COMPLETE",1:"UNKNOWN")_" DISCHARGE REPORT"
25 Q
26 ;
27DELETE K OUT W !!,*7,"Are you sure you want to delete this request" S %=2 D YN^DICN I $D(DTOUT)!(%<0) Q ;continue on timeout to set record
28 I $D(%),%=1 S DIK="^DVB(396," D ^DIK S OUT=1 W " ... deleted!",*7,!! H 2
29 Q
30 ;
31CHKDIV ;** Check for selected Division on 7131
32 K DVXST
33 N ADIV
34 S ADIV=$S($D(^DVB(396,D0,2)):$P(^(2),U,9),1:"""")
35 S:XDIV=ADIV DVXST=""
36 I '$D(DVXST) DO
37 .N ADT
38 .S ADT=""
39 .F ADT=0:0 S ADT=$O(^DVB(396,"AF",D0,ADT)) Q:ADT=""!($D(DVXST)) DO
40 ..S:($D(^DVB(396,"AF",D0,ADT,XDIV))) DVXST=""
41 Q
42 ;
43WRDIV ;** Write Division for 7131 - Loop DA in 'AF' X-ref
44 S TMP($J,"DVBA",$P(^(2),"^",9))=""
45 F DVBADT=0:0 S DVBADT=$O(^DVB(396,"AF",DA,DVBADT)) Q:DVBADT="" D LPDIV
46 W !
47 KILL TMP($J,"DVBA"),DVBADT,DVBADIV,DVBANAM
48 Q
49 ;
50LPDIV ;** Loop Division in 'AF' X-ref
51 S DVBADIV=0
52 F S DVBADIV=$O(^DVB(396,"AF",DA,DVBADT,DVBADIV)) Q:DVBADIV="" DO
53 .I '$D(TMP($J,"DVBA",DVBADIV)) DO
54 ..S DVBANAM=$P(^DG(40.8,DVBADIV,0),"^",1)
55 ..S TMP($J,"DVBA",DVBADIV)=""
56 ..W !,?68,$E(DVBANAM,1,9)
57 Q
58 ;
59DIVUPDT ;** Update 7131 Rpt Divisions & Tran Dates on new 7131
60 K DR,DIE,DA
61 S REQDTE=$P(^DVB(396,DVBAENTR,1),U,1),REQDIV=$P(^DVB(396,DVBAENTR,2),U,9)
62 S:'$D(^DVB(396,DVBAENTR,6)) DVBANEW=""
63 S:'$D(DVBANEW) NODE6=^DVB(396,DVBAENTR,6)
64 F LPPCE=1:1:10 DO
65 .S:LPPCE=1 FLDDIV=4.6,FLDDTE=4.7
66 .S:LPPCE=2 FLDDIV=5.6,FLDDTE=5.7
67 .S:LPPCE=3 FLDDIV=6.6,FLDDTE=6.7
68 .S:LPPCE=4 FLDDIV=7.6,FLDDTE=7.7
69 .S:LPPCE=5 FLDDIV=9.6,FLDDTE=9.7
70 .S:LPPCE=6 FLDDIV=11.6,FLDDTE=11.7
71 .S:LPPCE=7 FLDDIV=13.6,FLDDTE=13.7
72 .S:LPPCE=8 FLDDIV=15.6,FLDDTE=15.7
73 .S:LPPCE=9 FLDDIV=17.6,FLDDTE=17.7
74 .S:LPPCE=10 FLDDIV=20.6,FLDDTE=20.7
75 .I $P(DVBARPT(LPPCE),U,3)="P" D NEWCHK^DVBAUTL8 ;**Check for new report
76 .I $P(DVBARPT(LPPCE),U,3)="" D CLRCHK^DVBAUTL8 ;**Check to clear fields
77 I $P(^DVB(396,DVBAENTR,0),U,26)="P" DO ;**Check OPT TRT Rpt
78 .S FLDDIV=18.6,FLDDTE=18.7
79 .I $D(DVBANEW) D SETDR^DVBAUTL7 ;**OPT TRT Rpt included on new 7131
80 .I '$D(DVBANEW),($P(NODE6,U,26)="") D SETDR^DVBAUTL7 ;**OPT Rpt Added
81 I $P(^DVB(396,DVBAENTR,0),U,26)="" DO ;**Check OPT TRT Rpt
82 .I '$D(DVBANEW),($P(NODE6,U,26)'="") DO ;**OPT Rpt deselected via edit
83 ..S FLDDIV=18.6,FLDDTE=18.7
84 ..D CLEARDR^DVBAUTL7
85 I $D(DR) S DA=DVBAENTR,DIE="^DVB(396," D ^DIE
86 K FLDDTE,FLDDIV,LPPCE,REQDTE,REQDIV,DA,DR,DIE,Y,DVBANEW,NODE6
87 Q
Note: See TracBrowser for help on using the repository browser.