source: FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCRPON.m@ 1437

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

initial load of FOIAVistA 6/30/08 version

File size: 3.4 KB
Line 
1DVBCRPON ;ALB/GTS-557/THM-REPRINT C&P REPORTS ; 7/1/91 1:09 PM
2 ;;2.7;AMIE;**2,32**;Apr 10, 1995
3 ;
4SETUP D HOME^%ZIS K ULINE S FF=IOF,HD="Reprint C & P Exams"
5 S XDD=^DD("DD"),$P(ULINE,"_",70)="_"
6 I $G(DUZ(2))<1 W !!,*7,"Your division code is invalid.",!! H 2 G EXIT
7 S SUPER=0 I $D(^XUSEC("DVBA C SUPERVISOR",DUZ)) S SUPER=1
8 ;
9SETUP1 ;** Drops into if setup is ok
10 W @IOF,!?(IOM-$L(HD)\2),HD,!!!
11 S ONE="N",Y=DT X XDD
12 S DVBCDT(0)=Y,PGHD="Compensation and Pension Exam Report",LOC=DUZ(2),PG=0,DVBCSITE=$S($D(^DVB(396.1,1,0)):$P(^(0),U,1),1:"Not specified")
13 ;
14RASK W !!,"Select Reprint Option - (D)ate or (V)eteran: D// " R RTYPE:DTIME I RTYPE[U!('$T) G EXIT
15 I RTYPE'=""&(RTYPE'="D"&(RTYPE'="d"&(RTYPE'="v"&(RTYPE'="V")))) S RTYPE="E"
16 W:RTYPE="" "Date" W $S(RTYPE="D"!(RTYPE="d"):"ate",RTYPE="V"!(RTYPE="v"):"eteran",1:"") I RTYPE=""!(RTYPE="d") S RTYPE="D"
17 I RTYPE="v" S RTYPE="V"
18 I RTYPE'?1"D",RTYPE'?1"V" W !!,"Must be D or V" G RASK
19 G:RTYPE="D" ADATE I RTYPE="V" S ONE="Y"
20 ;
21ONLYLAB ;** Dropped into if the user doesn't exit from RASK and selects to
22 ;** to reprint by veteran
23 W !!,"Do you want just the Lab/X-ray results" S %=2 D YN^DICN I %=1 H 1 G REN^DVBCLABR ;** Branches to ^DVBCLABR which branches to ^DVBCPRNT
24 I %=0 W !!,"Enter Y to get just the Lab/X-ray results for the Vet",!,"or N to get the entire exam results AND Lab/X-ray." H 2 G ONLYLAB
25 ;
26ADATE ;** Jumped into from RASK or dropped into from ONLYLAB
27 I RTYPE="D" S %DT="AE",%DT("A")="Enter original printing date: ",%DT(0)=-DT D ^%DT G:+Y<0 EXIT S RUNDATE=+Y
28 ;
29WHO ;** Dropped into from ADATE
30 W !!,"Reprinted by the RO or MAS ? >> " R ANS:DTIME G:'$T EXIT I ANS=""!(ANS=U) G EXIT
31 I ANS'="R"&(ANS'="r"&(ANS'="m"&(ANS'="M"))) S ANS="E"
32 W $S(ANS="M"!(ANS="m"):"AS",ANS="R"!(ANS="r"):"O",1:"")
33 S:ANS="r" ANS="R"
34 S:ANS="m" ANS="M"
35 I ANS'?1"R"&(ANS'?1"M") W !,"Must be R for Regional Office or M for MAS.",!!,*7 G WHO
36 I ANS="R" K AUTO ;selects header type
37 I ANS="M" S AUTO=1
38 I ONE="Y" K OUT D ONEVET I $D(OUT) G EXIT
39 ;
40DEVICE ;** Dropped into from WHO
41 W @IOF S %ZIS="AEQ",%ZIS("B")="0;P-OTHER",%ZIS("A")="Output device: " D ^%ZIS G:POP EXIT
42 I $D(IO("Q")),ONE="N" S ZTRTN="GO^DVBCRPRT",ZTIO=ION,ZTDESC="2507 Final Exam Reprint" F I="XDD","D*","PGHD","RTYPE","RUNDATE","Y","AUTO","LOC","ANS","ULINE","ONE" S ZTSAVE(I)=""
43 I $D(IO("Q")),ONE="Y" S ZTRTN="OV^DVBCRPON",ZTIO=ION,ZTDESC="Single 2507 Final Exam Reprint" F I="XDD","D*","PGHD","RTYPE","RUNDATE","Y","AUTO","LOC","ANS","ULINE","ONE" S ZTSAVE(I)=""
44 I $D(IO("Q")) D ^%ZTLOAD W:$D(ZTSK) !!,"Request queued",!! H 1 G EXIT
45 I ONE="N" G GO^DVBCRPRT
46 I ONE="Y" G OV
47 ;
48ONEVET ;** Called from WHO when ONE=Y
49 W !! S DIC("W")="D DICW^DVBCUTIL",DIC="^DVB(396.3,",DIC(0)="AEQM" D ^DIC I X=""!(X=U) S OUT=1 Q
50 I +Y<0 W *7," ???" H 2 G ONEVET
51 S DA=+Y
52 S RO=$P(^DVB(396.3,DA,0),U,3) I RO'=DUZ(2)&('$D(AUTO))&(SUPER=0) W !!,*7,"Those results do not belong to your office.",!! H 3 G ONEVET
53 I RO=DUZ(2)&('$D(AUTO))&("RC"'[($P(^DVB(396.3,DA,0),U,18))) W *7,!!,"This request has not been released to the Regional Office yet.",!! H 3 G ONEVET
54 S PRTDATE=$P(^DVB(396.3,DA,0),U,16) I PRTDATE="" W *7,!!,"This has never been printed.",!! I SUPER=0 S OUT=1 H 3 Q
55 Q
56 ;
57OV ;** Run as a background task or in real-time
58 U IO S DA(1)=DA K DVBAON2 D SETLAB^DVBCPRNT,VARS^DVBCUTIL,STEP2^DVBCRPRT
59 K AUTO D ^%ZISC I '$D(ZTQUEUED) G SETUP1
60 ;
61EXIT K AUTO S LKILL=1 D:$D(ZTQUEUED) KILL^%ZTLOAD G KILL^DVBCUTIL
62 ;
63 Q
Note: See TracBrowser for help on using the repository browser.