source: FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCPRNT.m@ 1071

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

initial load of FOIAVistA 6/30/08 version

File size: 3.0 KB
Line 
1DVBCPRNT ;ALB/GTS-557/THM-FINAL REPORT DRIVER ; 5/17/91 10:29 AM
2 ;;2.7;AMIE;;Apr 10, 1995
3 ;
4 I '$D(DUZ(2)) W *7,!!,"You DIVISION NUMBER is incorrect.",! H 2 Q
5 I DUZ(2)<1 W !,*7,"Your DIVISION NUMBER is invalid.",! H 2 Q
6 ;
7SETUP K EDPRT,ULINE S XDD=^DD("DD"),$P(ULINE,"_",70)="_" K AUTO
8 D HOME^%ZIS S FF=IOF,HD="C & P Exam Printing" W @IOF,!?(IOM-$L(HD)\2),HD,!!!
9 S Y=DT X XDD S DVBCDT(0)=Y,PGHD="Compensation and Pension Exam Report",DVBCSITE=$S($D(^DVB(396.1,1,0)):$P(^(0),U,1),1:"Not specified")
10 W !!,"Note: All reports will be produced in 'terminal-digit' order.",!! H 1
11 ;
12DEVICE S %ZIS="AEQ",%ZIS("B")="0;P-OTHER",%ZIS("A")="Output device: " D ^%ZIS G:POP KILL^DVBCUTIL
13 I $D(IO("Q")) S ZTRTN="GO^DVBCPRNT",ZTIO=ION,ZTDESC="2507 Final Exam Report" F I="D*","XDD","ULINE","HD","FF","PGHD" S ZTSAVE(I)=""
14 I $D(IO("Q")) D ^%ZTLOAD W:$D(ZTSK) !!,"Request queued",!! K ZTSK G KILL^DVBCUTIL
15 ;
16GO D STM^DVBCUTL4
17 U IO K ^TMP($J) D HDA S (XCNT,XPRINT)=0
18 F DA(1)=0:0 S DA(1)=$O(^DVB(396.3,"AF","R",DUZ(2),DA(1))) Q:DA(1)="" DO
19 .I $D(^DVB(396.3,DA(1),0)) D GO1 S XPRINT=1,XCNT=XCNT+1
20 .I '$D(^DVB(396.3,DA(1),0)) D BADXRF
21 I XPRINT=0 K XPRINT,XPG,XXLN W !!!!!?25,"Nothing to print",!! H 2 D:$D(ZTQUEUED) KILL^%ZTLOAD G KILL^DVBCUTIL
22 I XCNT>0,XPRINT=1 W !!,"Total requests to be printed: ",XCNT,!
23 K XCNT,XXLN,XPG,XPRINT,OUT
24 D SETLAB
25 S (XCN,PNAM)=""
26 F DVBCN=0:0 S XCN=$O(^TMP($J,XCN)) Q:XCN="" F JJ=0:0 S PNAM=$O(^TMP($J,XCN,PNAM)) Q:PNAM="" K PRINT F DA(1)=0:0 S DA(1)=$O(^TMP($J,XCN,PNAM,DA(1))) Q:DA(1)="" S DA=DA(1) D VARS^DVBCUTIL,STEP2^DVBCPRN1 I '$D(AUTO) D ^DVBCLABR,LKILL^DVBCUTL3
27 S XRTN=$T(+0)
28 D SPM^DVBCUTL4
29 K DVBCN S LKILL=1 D:$D(ZTQUEUED) KILL^%ZTLOAD G KILL^DVBCUTIL
30 ;
31GO1 S DFN=$P(^DVB(396.3,DA(1),0),U,1),PNAM=$P(^DPT(DFN,0),U,1) W $E(PNAM,1,25),?28,$E($P(^(0),U,9),1,3)_" "_$E($P(^(0),U,9),4,5)_" "_$E($P(^(0),U,9),6,9)
32 S CNUM=$S($D(^DPT(DFN,.31)):$P(^(.31),U,3),1:"Missing") W ?43,CNUM,?55 S Y=$P(^DVB(396.3,DA(1),0),U,2) X XDD W Y,! D:$Y>(IOSL-16) HDA
33 S XCN=$E(CNUM,$L(CNUM)-1,$L(CNUM)),XCN=+XCN
34 I PNAM]"" S ^TMP($J,XCN,PNAM,DA(1))=""
35 K PNAM,XCN,CNUM
36 Q
37 ;
38SETLAB N XX S XX=1,DVBCRALC(XX)="^",Y=0
39 F S Y=$O(^DVB(396.1,1,4,"B",Y)) Q:(Y="") I $D(^SC(+Y,0)) S DVBCRALC(XX)=DVBCRALC(XX)_+Y_U I $L(DVBCRALC(XX))>230 S XX=XX+1,DVBCRALC(XX)="^"
40 Q
41 ;
42HDA S:'$D(XPG) XPG=0 S XPG=XPG+1
43 I (IOST?1"C-".E)!($D(DVBAON2)) W @IOF
44 S:('$D(DVBAON2)) DVBAON2=""
45 W !,"Final C&P Reports for print date " S Y=DT X XDD W Y,!!,"Operator: ",$S($D(^VA(200,+DUZ,0)):$P(^(0),U,1),1:"Unknown operator"),!,"Location: ",$S($D(^DIC(4,+DUZ(2),0)):$P(^(0),U,1),1:"Unknown location"),!
46 W !,"Veteran Name",?28,"SSN",?43,"C-Number",?55,"Request date",!
47 F XXLN=1:1:79 W "-"
48 W !!
49 Q
50 ;
51WARN W !!,*7,"Too many locations to store! Some locations may not be reported.",!! H 3 S OUT=1
52 Q
53 ;
54BADXRF ; ** Display a message that a bad cross reference exists **
55 W !,"A bad 'D' X-Reference exists on the 2507 Request File (#396.3) for"
56 W " DA="_DA(1)_"."
57 W !,"Please notify IRM at the facility where you have created"
58 W " this report.",!!
59 Q
Note: See TracBrowser for help on using the repository browser.