source: FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBADSCK.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 
1DVBADSCK ;ALB/GTS-557/THM-DISCHARGE CHECKER ;21 JUL 89
2 ;;2.7;AMIE;**15,14,24,32**;Apr 10, 1995
3 ;
4 S DVBAMAN=""
5 D NOPARM^DVBAUTL2 G:$D(DVBAQUIT) KILL
6 S HD="MANUAL 7132 PROCESSING" D HOME^%ZIS K ^TMP($J)
7DATE S %DT(0)=-DT,%DT="AE",%DT("A")="Enter BEGINNING date: "
8 W @IOF,!?(IOM-$L(HD)\2),HD,!!!
9 D ^%DT G:Y<0 KILL S (BDATE,BDATE1)=Y,BDATE=BDATE-.1
10 S %DT("A")=" and ENDING date: ",%DT="AE" D ^%DT G:Y<0 DATE S (EDATE1,EDATE)=Y,EDATE=EDATE+.5
11 I EDATE<BDATE W *7,!!,"Invalid date sequence." H 3 G DATE
12 K %DT S Y=DT X ^DD("DD") S FDT(0)=Y
13 W !! S %ZIS="AEQ",%ZIS("A")="Enter output device: " D ^%ZIS K %ZIS G:POP KILL
14 I $D(IO("Q")) S ZTRTN="DATA^DVBADSCK",ZTIO=ION,NOASK=1,ZTDESC="AMIE Discharge Checker" F I="BDATE*","EDATE*","FDT(0)","HD","NOASK","DVBAMAN" S ZTSAVE(I)=""
15 I $D(IO("Q")) D ^%ZTLOAD W:$D(ZTSK) !!,"Request queued.",! G KILL
16 G DATA
17 ;
18ZTM D NOPARM^DVBAUTL2 G:$D(DVBAQUIT) KILL
19 I '$D(DT) S X="T" D ^%DT S DT=Y
20 S Y=DT X ^DD("DD") S FDT(0)=Y
21 K ^TMP($J) S X="T-1" D ^%DT Q:Y<0 S (BDATE,BDATE1)=Y,BDATE=Y-.1,(EDATE1,EDATE)=Y,EDATE=Y+.5 G DATA
22 ;
23CHK ;* Find the IFN of the 7131 which matches the admission date (If a 7131
24 ;* exists).
25 F XDA=0:0 S XDA=$O(^DVB(396,"B",DFN,XDA)) Q:XDA="" I $P($G(^DVB(396,XDA,0)),U,4)=ADMDT&($P($G(^DVB(396,XDA,2)),U,10)="A") Q
26 QUIT
27 ;
28SET ;* Set up TMP global of admissions for discharges within range
29 S DFN=DA,VAINDT=$S($D(^DGPM(+MB,0)):$P(^(0),U,1),1:""),VAINDT=VAINDT-.000002,VA200="" D INP^VADPT K VA200 S ADMDT=$P(VAIN(7),U,1),ADMNUM=VAIN(1)
30 ;I ADMDT]"" S ADMDT=$P(ADMDT,".",1)
31 Q:ADMDT="" S ^TMP($J,ADMDT,+ADMNUM,DA)=""
32 Q
33 ;
34SET1 ;* Get the discharge type and execute CREATE and CREAT1 as needed
35 S DCHPTR=$P(^DGPM(LADM,0),U,17),TDIS=$S($D(^DGPM(+DCHPTR,0)):$P(^(0),U,18),1:"") I TDIS="" S TDIS="Unknown discharge type"
36 S:'$D(^DG(405.2,+TDIS,0)) TDIS="Unknown discharge type" I $D(^(0)) S TDIS=$S($P(^DG(405.2,+TDIS,0),U,1)]"":$P(^(0),U,1),1:"Unknown discharge type")
37 I XDA]"",$D(^DVB(396,XDA,0)) D CREATE Q
38 I TDIS["DEATH"!(TDIS["TO CNH") D CREAT1
39 Q
40 ;
41LOOK ;* Loop through Admission Date TMP global execute CHK and SET1
42 K MA,DA,MB F ADMDT=0:0 S ADMDT=$O(^TMP($J,ADMDT)) Q:ADMDT="" F LADM=0:0 S LADM=$O(^TMP($J,ADMDT,LADM)) Q:LADM="" F DFN=0:0 S DFN=$O(^TMP($J,ADMDT,LADM,DFN)) Q:DFN="" D CHK,SET1
43 Q
44 ;
45DATA U IO W:(IOST?1"C-".E) @IOF
46 W !,"Notices of discharge created on "_FDT(0)_" for discharge date range " S Y=$P(BDATE1,".",1) X ^DD("DD") W Y," TO " S Y=$P(EDATE1,".",1) X ^DD("DD") W Y,!!!
47 W "Name",?35,"SSN",?50,"Admission date",! F LINE=1:1:IOM W "-"
48 ;
49 ;* Set up XRO array containing regional office station numbers
50 ;* contained in the AMIE Site Parameter File
51 ;
52 F I=0:0 S I=$O(^DVB(396.1,1,1,I)) Q:I=""!(+I=0) S J=$P(^(I,0),U,1),J=$S($D(^DIC(4,+J,99)):$P(^(99),U),1:"") I J]"" S XRO(J)=""
53 ;
54 ;* Loop through Discharges ("AMV3") within entered date range DO SET
55 ;* when a discharge is found
56 ;
57 W !! S COUNT=0,MA=BDATE F J=0:0 S MA=$O(^DGPM("AMV3",MA)) Q:$P(MA,".")>EDATE!(MA="") F DA=0:0 S DA=$O(^DGPM("AMV3",MA,DA)) Q:DA="" F MB=0:0 S MB=$O(^DGPM("AMV3",MA,DA,MB)) Q:MB="" I MA'>EDATE D SET
58 ;
59 ;* Loop through admission date TMP global
60 ;
61 D LOOK W @IOF,!!!,"Notice to MAS operator on ",FDT(0),!!! I '$D(NEW) W "There were no NOTICES OF DISCHARGE to create.",!!!
62 I $D(NEW) W "There ",$S(COUNT=1:"was ",1:"were ")_COUNT_$S(COUNT=1:" notice",1:" notices")_" of discharge created.",!!!
63 ;
64KILL I $D(DVBAMAN)&($D(ZTQUEUED)) D KILL^%ZTLOAD
65 K NEW,COUNT,XRO G KILL^DVBAUTIL
66 ;
67CREATE ;create notice
68 ;* If a Notice of Discharge is requested on 7131, created it
69 I $D(^DVB(396,XDA,2)) Q:$P(^(2),U,10)="L"
70 Q:$P(^DVB(396,XDA,0),U,5)'="YES" Q:$P(^(0),U,9)'="P"
71 S XADMDT=$P(^DVB(396,XDA,0),U,4) Q:ADMDT'=XADMDT
72CREAT1 Q:'$D(^DPT(DFN,0)) D ADM^DVBAVDPT
73 I $G(CFLOC)="" Q ;No station # for a claim folder location.
74 I '$D(XRO(CFLOC))&(CFLOC'=376) Q ;not a user RO
75 I CFLOC=376,TDIS["DEATH" S CFLOC=$O(XRO(0)) Q:CFLOC=""
76 Q:$D(^DVB(396.2,"D",ADMDT,DFN)) ;quit if one for admit date exists
77 S (DIC,DIE)="^DVB(396.2,",DR="3.5///"_CFLOC_";1///"_ADMDT_";2///"_LADM_";3///R" S DLAYGO=396.2,DIC(0)="QLM",X=""""_SSN_"""" D ^DIC Q:+Y<0 S DA=+Y D ^DIE S NEW=1,COUNT=COUNT+1 K DLAYGO
78 W PNAM,?35,SSN S Y=ADMDT X ^DD("DD") W ?50,Y,?70,TDIS,!
79 Q
80 ;
81DOC ;XADMDT=admission date on 7131
82 ;XDA=7131 file pointer--not all patients will have it
83 ;DA=patient file pointer
84 ;MB,LADM=admission pointers
85 ;NOTE: DEATH,TO CNH discharges will NOT record discharge dates
Note: See TracBrowser for help on using the repository browser.