source: WorldVistAEHR/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCADE1.m@ 724

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

initial load of WorldVistAEHR

File size: 3.5 KB
Line 
1DVBCADE1 ;ALB/GTS-557/THM-PRINT/REPRINT WORKSHEETS ; 5/7/91 11:20 AM
2 ;;2.7;AMIE;**12**;Apr 10, 1995
3 ;from DVBCADEX
4 K RPRT I '$D(^TMP($J,"NEW")) W !!,"No exams selected ...",!! H 2 Q
5 D COPY G EN
6 ;
7CK1 I $P(^DVB(396.4,EXDA,0),U,4)'="O"!($P(^(0),U,5)="Y"),'$D(RPRT) Q
8 K CMBN I $P(TEMP("NEW",ZC,EXMNM),U,2)="A" S CMBN=1
9 S PGM=$S($D(^DVB(396.6,JY,0)):$P(^(0),U,4),1:"")
10 I PGM="" Q
11 S TNAM=$P(^(0),U,1),PGM="^"_PGM D @PGM
12 N DVBCEXM S DVBCEXM=EXMNM K DVBCFF
13 I ZC="A" DO
14 .S DVBCEXM=$O(TEMP("NEW","A",DVBCEXM))
15 .I DVBCEXM'="" S DVBCFF=""
16 .I '$D(DVBCFF) S DVBCEXM=$O(TEMP("NEW","Z","")) DO
17 ..I DVBCEXM'="" S DVBCFF=""
18 I ZC="Z" DO
19 .S DVBCEXM=$O(TEMP("NEW","Z",DVBCEXM))
20 .I DVBCEXM'="" S DVBCFF=""
21 W:(IOST?1"P-".E)&($D(DVBCFF)) @IOF
22 K DVBCFF,DVBCEXM
23 S $P(^DVB(396.4,EXDA,0),U,5)="Y"
24 K CMBN,TNAM,PGM Q
25 ;
26EN W @FF,!!,"Worksheets should be sent to a printer." S %ZIS="AEQ",%ZIS("A")="Output device: " D ^%ZIS Q:POP K %ZIS
27 ;
28QUE I $D(IO("Q")) S ZTRTN=$S($D(RPRT):"GO2^DVBCADE1",1:"GO^DVBCADE1"),ZTDESC="Print C&P Work Sheets" F I="DUZ","DA*","DFN","TEMP*","REQDA","OWNDOM","RPRT","C*","SSN","PNAM" S ZTSAVE(I)=""
29 I $D(IO("Q")) D ^%ZTLOAD S:'$D(ZTSK) POP=1 W:$D(ZTSK) !!,"Request queued",!! H 1 K IO("Q"),ZTRTN,ZTIO,ZTDESC K:'$D(RPRT) ZTSK Q
30 Q:$D(RPRT)
31 ;
32GO U IO S DA=REQDA D VARS^DVBCUTIL
33 S EXMNM="" F ZC="A","Z" F JZ=0:0 S EXMNM=$O(TEMP("NEW",ZC,EXMNM)) Q:EXMNM="" S JY=$P(TEMP("NEW",ZC,EXMNM),U,1),EXDA=$P(TEMP("NEW",ZC,EXMNM),U,3) D CK1
34 D ^%ZISC D:$D(ZTQUEUED) KILL^%ZTLOAD Q
35 ;
36SET S EXDA=+Y,JY=$P(Y,U,2) D EXMNM I '$D(OUT) D FMT D:$D(OUT) QUES Q:$D(OUT) I '$D(OUT) S ^TMP($J,"NEW",EXMNM)=JY_U_FMT_U_EXDA H 1 W @FF,!!,HD4,!!!
37 Q
38 ;
39 ;print/reprint worksheets
40RPRT S RPRT=1 D HOME^%ZIS S FF=IOF
41 ;
42EN1 K ^TMP($J),DA,EXDA,EXMNM,OUT,DIC
43 W @FF,!,"Print/Reprint C&P Worksheets",!!!
44 S DIC="^DVB(396.3,",DIC(0)="AEQM",DIC("A")="Select VETERAN NAME: "
45 D ^DIC G:X=""!(X=U) EXIT S (REQDA,DA(1))=+Y
46 S HD4="Select exam(s) to print or enter ALL to print all exams."
47 W !!,HD4,!!!
48 K OUT,OUT1
49 F I=0:0 K DIC,Y,D S DIC("A")="Select EXAM: " W ?10,DIC("A") S DIC="^DVB(396.6,",DIC("S")="I $D(^DVB(396.4,""ARQ""_REQDA,+Y))",DIC(0)="EQ" R X:DTIME S:'$T OUT1=1 Q:$D(OUT1)!(X="")!(X=U)!(X="ALL")!(X="all") DO
50 .D ^DIC D:X["?" QUES W:+Y<0 !!
51 .I +Y>0 K DIC S X=+Y,DIC="^DVB(396.4,",DIC(0)="EQ",D="ARQ"_REQDA DO
52 ..D MIX^DIC1 K DIC,D
53 .I +Y>0 D SET
54 G:$D(OUT1) EXIT
55 I $D(X),X="ALL"!(X="all") F EXDA=0:0 S EXDA=$O(^DVB(396.4,"C",REQDA,EXDA)) Q:EXDA="" D FMT G:$D(OUT1) EXIT Q:$D(OUT) S ^TMP($J,"NEW",EXMNM)=JY_U_FMT_U_EXDA
56 I '$D(^TMP($J,"NEW")) W *7,!!,"No exams selected ..." H 2 G EN1
57 D COPY,EN G:POP EXIT I $D(ZTSK) K ZTSK G EN1
58 ;
59GO2 U IO S DA=DA(1) D VARS^DVBCUTIL
60 S OWNDOM=$P(^DVB(396.3,DA(1),0),U,22) I OWNDOM]"" D ^DVBCTRNN
61 S EXMNM="" F ZC="A","Z" F JZ=0:0 S EXMNM=$O(TEMP("NEW",ZC,EXMNM)) Q:EXMNM="" S JY=$P(TEMP("NEW",ZC,EXMNM),U,1),EXDA=$P(TEMP("NEW",ZC,EXMNM),U,3) D CK1
62 D ^%ZISC G:'$D(ZTQUEUED) EN1 I $D(ZTQUEUED) G EXIT
63 ;
64EXMNM K OUT S JY=$P(^DVB(396.4,EXDA,0),U,3)
65 S EXMNM=$S($D(^DVB(396.6,JY,0)):$P(^(0),U,1),1:"")
66 I EXMNM="" S OUT=1 ;!($D(^TMP($J,"NEW",EXMNM))) S OUT=1
67 Q
68 ;
69FMT W @IOF,! D EXMNM W !!?10,EXMNM,!
70 K OUT,OUT1 I $P(^DVB(396.4,EXDA,0),U,4)'="O" W *7,!!?5,"Status is not OPEN - No worksheet will be printed. " H 3 S OUT=1 Q
71 S FMT="F"
72 Q
73 ;
74COPY K TEMP S X="" F Y=0:0 S X=$O(^TMP($J,"NEW",X)) Q:X="" S Z=$S($P(^TMP($J,"NEW",X),U,2)="F":"A",1:"Z"),TEMP("NEW",Z,X)=^TMP($J,"NEW",X) ;full come out first
75 Q
76 ;
77QUES W !!,"Press RETURN to continue " R ANS:DTIME
78 W @FF,!!,HD4,!!!
79 Q
80 ;
81EXIT K RPRT,FMT,OUT,OUT1 D:$D(ZTQUEUED) KILL^%ZTLOAD G KILL^DVBCUTIL
Note: See TracBrowser for help on using the repository browser.