source: FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBAPND1.m@ 811

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

initial load of FOIAVistA 6/30/08 version

File size: 3.3 KB
Line 
1DVBAPND1 ;ALB ISC/GTS-AMIE PENDING RPT UT ;13 JAN 93@08:10 ; 7/2/90 2:48 PM
2 ;;2.7;AMIE;**14,17**;Apr 10, 1995
3 ;
4 ; ** The following routines are called from DVBAPEND **
5SORTDIV W !!,"Sort by Division" S %=1 D YN^DICN
6 I $D(DTOUT)!(%<0) K DTOUT S Y=-1 Q
7 I $D(%Y),(%Y["?") W !!,*7,"Enter Y to sort by the Division you"
8 I $D(%Y),(%Y["?") W !,"select or enter N to report ALL Divisions."
9 I $D(%Y),(%Y["?") G SORTDIV
10 I %'=1 S SELDIV="N",DIVNUM=0 Q
11 I %=1 S SELDIV="Y" G ENTDIV
12 W !,*7,"Invalid response.",!! G SORTDIV
13 ; ** Allow user to enter a selected Division to report **
14ENTDIV S DIC="^DG(40.8,",DIC(0)="AEMQ",DIC("A")="Division number: "
15 D ^DIC K DIC S DIVNUM=+Y
16 S DIVNAM=$S($D(^DG(40.8,+Y,0)):$P(^(0),"^",1),1:"Unknown Division")
17 Q
18 ;
19DCHGDT S DCHGDT="",DCHPTR=$P(^DGPM(XJ,0),U,17),XADMDT=$P(^(0),U,1) I DCHPTR]"",$D(^DGPM(+DCHPTR,0)) S DCHGDT=$P(^DGPM(+DCHPTR,0),U,1)
20 K DCHPTR
21 Q
22 ;
23PRINT S DOCTYPE=$S($D(^DVB(396,DA,2)):$P(^(2),U,10),1:""),DFN=$P(^DVB(396,DA,0),U,1),ADMDT=$P(^(0),U,4),RDATE=$P(^(1),U,1),PNAM=$P(^DPT(DFN,0),U,1),SSN=$P(^(0),U,9),CNUM=$S($D(^(.31)):$P(^(.31),U,3),1:"UNKNOWN")
24 I RO="Y" S CFLOC=$$STATION^DVBAUTL1(DFN),CFLOC=$S(CFLOC>0:CFLOC,1:9999) Q:CFLOC'=RONUM&(CFLOC'=0)&(CFLOC'=376)
25 K ^TMP("DVBA","ADMIT",$J)
26 F XI=0:0 S XI=$O(^DGPM("APTT1",DFN,XI)) Q:XI="" F XJ=0:0 S XJ=$O(^DGPM("APTT1",DFN,XI,XJ)) Q:XJ="" D DCHGDT S ^TMP("DVBA","ADMIT",$J,XADMDT,DFN)=XI_U_DCHGDT
27 W:SELDIV="Y" !,?10,"Division: "_ADIV,!
28 W:SELDIV="N" !,?10,"Original Division: "_ADIV,!
29 W !,PNAM,?49,"SSN: ",SSN,!,?44,"Claim no: ",CNUM,!,?38,$S(DOCTYPE="L":" Activity date: ",1:"Admission date: "),$$FMTE^XLFDT(ADMDT,"5DZ"),!,?40,"Request date: ",$$FMTE^XLFDT(RDATE,"5DZ")
30 S DCHGDT=""
31 I $D(^TMP("DVBA","ADMIT",$J,+ADMDT,DFN)) S:DOCTYPE="A" DCHGDT=$P(^TMP("DVBA","ADMIT",$J,+ADMDT,DFN),U,2)
32 D ELAPSED
33 W ! I DCHGDT]"" S Y=DCHGDT X DVBADD W "** Discharged: ",Y
34 W ?40,"Elapsed days: ",EDAYS,!!,?3,"Items Pending:"
35ITEMS F Q=9,11,13,15,17,19,21,23,26,28 I $P(^DVB(396,DA,0),U,Q)="P" D PRINT1 Q:DVBAQUIT=1
36 S Q=7 I $P(^DVB(396,DA,1),U,Q)="P" D PRINT1 Q:DVBAQUIT=1
37 W !! W:$D(^DVB(396,DA,2)) "Requested by: ",$S($P(^DVB(396,DA,2),U,8)]"":$P(^(2),U,8),1:" (Not specified) ")," AT ",$S($P(^(2),U,7)]"":$P(^(2),U,7),1:" (Not specified) "),! F L=1:1:79 W "-"
38 W !
39 D TOP Q:DVBAQUIT=1
40 Q
41 ;
42PRINT1 S:$D(^DVB(396,DA,6)) GDIVPTR=$P(^DVB(396,DA,6),"^",Q)
43 S:'$D(^DVB(396,DA,6)) GDIVPTR=$P(^DVB(396,DA,2),"^",9)
44 S:+GDIVPTR>0 GDIVNAM=$P(^DG(40.8,GDIVPTR,0),"^",1)
45 S:+GDIVPTR'>0 GDIVNAM=""
46 S NODTA=1 I QQ S MC=$T(@Q),MD=$P(MC,";;",2) S GDIV=" ("_$E(GDIVNAM,1,(9+(23-$L(MC))))_")" W !,?8,MD,GDIV S QQ='QQ Q
47 I 'QQ S MC=$T(@Q),MD=$P(MC,";;",2) S GDIV=" ("_$E(GDIVNAM,1,(9+(23-$L(MC))))_")" W ?46,MD,GDIV S QQ='QQ I $Y>22 D TOP Q:DVBAQUIT=1
48 Q
49 ;
50TOP I IOST?1"C-".E,'$D(NOASK) W !!,*7,"Press RETURN to continue or ""^"" to exit " R ANS:DTIME W @IOF I ANS=U!('$T) S DVBAQUIT=1 Q
51 I $Y'<53 D HEADER
52 Q
53 ;
54ELAPSED K EDAYS,X1,X S X1=DT,X=RDATE D ^XUWORKDY
55 S EDAYS=X
56 Q
57 ;
58HEADER S PG=PG+1 W:(IOST?1"C-".E)!(PG>1) @IOF,!
59 W ?(80-$L(HEAD)\2),HEAD,?71,"Page: ",PG,! I HEAD2]"" W ?(80-$L(HEAD2)\2),HEAD2,!
60 W ?(80-$L(PROCDT)\2),PROCDT,!!
61 Q
62FIELDS ;
637 ;;ADMISSION RPT
649 ;;NOTICE OF DISCHARGE
6511 ;;HOSPITAL SUMMARY
6613 ;;21-DAY CERTIFICATE
6715 ;;OTHER/EXAM REVIEW RMKS
6817 ;;SPECIAL REPORT
6919 ;;COMPETENCY REPORT
7021 ;;VA FORM 21-2680
7123 ;;ASSET INFORMATION
7226 ;;OPT TREATMENT REPORT
7328 ;;BEGINNING DATE/CARE
74 Q
Note: See TracBrowser for help on using the repository browser.