source: FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBAUTIL.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.3 KB
Line 
1DVBAUTIL ;ALB ISC/THM-AMIE UTILITIES ; 1/16/91 2:58 PM
2 ;;2.7;AMIE;**17,32**;Apr 10, 1995
3 ;
4SORT W !!,"Sort by Regional Office number" S %=1 D YN^DICN I $D(DTOUT)!(%<0) K DTOUT S Y=-1 Q
5 I $D(%Y) I %Y["?" W !!,*7,"Enter Y to sort by the Regional Office number you",!,"select or enter N to get ALL Regional Offices reported." G SORT
6 I %'=1 S RO="N",RONUM=0 Q
7 I %=1 S RO="Y" G RONUM
8 W !,*7,"Invalid response.",!! G SORT
9 ;
10RONUM W !,"Regional Office number: " R RONUM:DTIME G:RONUM["^" SORT I '$T!(RONUM="") W *7 S Y=-1 Q
11 I RONUM'?1.3N W *7," Must be 1-3 numbers.",!! G RONUM
12 Q
13 ;
14KILL ;kill all variables and exit selected program
15 D ^%ZISC
16KILL1 K %DT,%ZIS,ANS,BDATE,CNUM,EDATE,L,MA,DA,NODTA,PNAM,Q,QQ,RDATE,SSN,XY,VER,J,LN,POP,FINALDTE,ADMDT,BEDSEC,CFLOC,DIAG,DCHGDT,HEAD,HEAD1,MB,RCVAA,RCVPEN,A,TYPE,C,ADMNUM,DIPGM,DIS,HNAME,DVBAQUIT,DSRP
17 K WARD,NOASK,^TMP($J),DTOUT,ZTSK,IO("C"),I,RO,RONUM,LADM,K,RADM,%X,%Y,%XX,%YY,X,Y,ICDAT2,ICDAT,LOS,TDIS,DIC,POP,DVBATYPS,TO,NUMSEL,REP,DVBAFIND,DVBATP,DVBAPRNT,SITE,LINE,OPER,PG,HD,HD1,HEAD2,DVBADD
18 K ZTIO,ZTDESC,ZTRTN,DATA,SC,LDCH,FDT(0),NAME,DIE,DR,ZX,ZI,XDA,XADMDT,DLAYGO,HD,D,DIC,Y,Z,ZTYPE,D0,D1,DI,DQ,CNM,CFLC,XDTA,MC,MD,PROCDT,ADMDATE,EDAYS,CNT,XLOC,TEMP,TEMPDA,%ZIS,%IS,DIVHD,XDIV,DVBADIV,ADIV,BDT,EDT
19 K ZTYPE,DO,DTAR,X,Y,HEAD,HEAD1,ADTYPE,NDCH,DOCTYPE,ELIG,INCMP,LG,OUT,LADMDT,NONE,BDATE1,XDA2,ADM,DFN,DISCH,XCN,LCN,HOSP,NODE,T,TRN,ZTSAVE,ZDT,ZDT1,ZDA,IO("Q"),IOP,BDIV,EDIV,BDT1,EDT1,NEWREQ,BED,STAT,DVBADIC,ADMNUM
20 K X2,DHD,DIWF,DIWL,DIWR,DVBASC,DVBAELIG,FNLDT,CFLC,HIST,DVBAELST,OLDY,PDATE,ZTDTH,DTA,VAINDT,VAIN,WWHO,SDATE,%,DVBAQUIT,NODE,NOFINAL,^TMP("ADMIT",$J),LOC,AA,DVBASTAT,OLDY,ADMDT,ANS1,CURADMDT,DVBADT,DVBAH,DVBAQ
21 K DVBAI,DVBAT,HEADDT,HOSPDAYS,LBEDSEC,LDCHGDT,LDIAG,LLADM,LTDIS,MSG,MSG1,VX,VY,X1,XLINE,ZJ,ZY,ZZ,LOC,QUIT,QUIT1,^UTILITY($J),^TMP("DVBA",$J),^TMP("DVBA","PEN"),^TMP("DVBA","A&A"),DVBACEPT,DCHPTR,DVBA
22 Q
23 ;
24LOS ;compute length of stay for discharge report
25 S %DT="T" S X=ADMDT D ^%DT S X2=Y
26 S X=DCHGDT D ^%DT S X1=Y K Y
27 D ^%DTC S LOS=X I LOS=0 S LOS=""
28 Q
29DATE W !,?5,"The entry of future dates is NOT allowed.",!
30 S %DT(0)=-DT
31 S %DT("A")="BEGINNING date: ",%DT="AET" D ^%DT W:X="^"!(Y=-1) !! Q:X=""!(Y=-1) S BDATE=Y
32 S %DT("A")=" ENDING date: ",%DT="AET" D ^%DT S EDATE=Y Q:X="^"
33 I EDATE<BDATE W !!,*7,"Invalid date sequence. Beginning date must be before the ending date.",!! H 2 G DATE
34 S BDATE=BDATE-.5,EDATE=EDATE+.5
35 D SORT K %DT(0) Q
36 ;
37DICW S DVBADIC(0,"W")="S ZX=$P(^DVB(396,+Y,0),U,4) W:$X>40 ! W "" Admission date: "",$$FMTE^XLFDT(ZX,""5DZ"") W "" "",$S($P(^(1),U,12)'="""":""Finalized"",1:""Open"")"
38 ;
39DICW1 S DVBADIC(1,"W")="S ZX=$P(^DVB(396,+Y,0),U,4) W:$X>40 ! W "" Activity date: "",$$FMTE^XLFDT(ZX,""5DZ"") W "" "",$S($P(^(1),U,12)'="""":""Finalized"",1:""Open"")"
40 ;
41DICW2 S DIC("W")="S ZTYPE=$S($D(^DVB(396,+Y,2)):$P(^(2),U,10),1:""A"") X $S(ZTYPE=""L"":DVBADIC(1,""W""),1:DVBADIC(0,""W""))"
42 Q
43 ;
44FINAL ;
45 S $P(^DVB(396.1,1,0),"^",X)=DT ;x is the corresponding date field
46 G KILL1
47 ;
48DUZ2 K DVBAQUIT
49 I $G(DUZ(2))="" W *7,!!,"You have no division code. Please contact the site manager.",!! H 3 S DVBAQUIT=1 Q
50 S DVBAD2=$S($D(^DIC(4,+DUZ(2),99)):$P(^(99),U,1),1:0)
51 I DVBAD2=0 W *7,!!,"Your division code is invalid.",!! H 3 S DVBAQUIT=1
52 ; Flag if the division has no station # in the INSITUTION file.
53 I $G(DVBAD2)="" W *7,!!,"Your division has no station number defined in the INSTITUTION file.",!,"Please consult IRM to request a unique station number for your division.",!! H 3 S DVBAQUIT=1
54 Q
55S ;
56 ;this code is currently not available but will be in future version
57 ;of AMIE.
58 Q
59S1 ;
60 ;this code is currently not available but will be in future version
61 ;of AMIE.
62 Q
63K ;
64 ;this code is currently not available but will be in future version
65 ;of AMIE.
66 Q
67K1 ;
68 ;this code is currently not available but will be in future version
69 ;of AMIE.
70 Q
71 ;
72EXIT ;called from the DVBAREG1 routine, kills off variables at end.
73 S VAR(1,0)="0,0,0,0:2,1^"
74 D WR^DVBAUTL4("VAR")
75 K VAR,ADM,ADMDT,ANS,CNUM,DA,DFN,DIC,DIE,DR,PNAM,SSN,ZA,OPER,X,Y,POP,LOC,%,ZI,ONFILE,REOPEN,DVBADIV,STAT,ZX,HD,I,NAME,HNAME,DTAR,DTOUT,%Y,DOCTYPE,%Y1,DQ,DVBADIC,OUT,ZTYPE,A,ADMNUM,ANS1,OLDY,DVBASTAT,DVBAENTR,DVBAEDT
76 K DVBAD2,DVBAX,DVBCSSNO,AROWOUT,DVBADM,DVBANL,DVBAPT,DVBAQUIT,DVBBDT,DVBCHK,DVBDISP,DVBEDT,DVBSPCOD,DVBVAR,DVBCNT,DVBAY,DVBDOC,DVBAIFN,DVBANS
77 K ^TMP("DVBA",$J),^UTILITY("DIQ1",$J)
78 Q
79 ;
Note: See TracBrowser for help on using the repository browser.