source: FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCADE2.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: 3.1 KB
Line 
1DVBCADE2 ;ALB/GTS-557/THM-ADD C&P EXAMS TO REQUESTS, PART 2 ; 4/18/91 7:23 AM
2 ;;2.7;AMIE;**1,12**;Apr 10, 1995
3 ;
4EXMHD W @FF,?(IOM-$L(HD2)\2),HD2,!!,"Please select the exams for ",$P(PNAM,",",2,99)," ",$P(PNAM,",",1),!,"Use ? to see a list exams available for selection.",!!
5 ;
6EXMSEL I $D(DVBCLCKD) Q
7 S DIC("S")="I $P(^(0),U,5)'=""I""",DIC="^DVB(396.6,",DIC(0)="AEQM"
8 S DIC("A")="Select EXAM: "
9 K OUT D ^DIC S:$D(DTOUT) OUT=1 Q:$D(OUT)
10 G:X=""!(X=U) EXMDIS ;Only out of EXMSEL
11 I +Y<0 W " ??",*7 G EXMSEL
12 S EXMDA=+Y,EXMNM=$P(^DVB(396.6,+Y,0),U,1)
13 I $D(^TMP($J,"NEW",EXMNM)) W " Duplicate - ignored",!,*7 G EXMSEL
14 I $D(^DVB(396.4,"APS",DFN,EXMDA,"O")) W *7," -- already ON FILE",! G EXMSEL
15 I $D(^DVB(396.4,"APS",DFN,EXMDA,"X"))!($D(^DVB(396.4,"APS",DFN,EXMDA,"RX"))) W *7," -- Previously cancelled, addition allowable",!
16FMT ;drop into
17 S EXCNT=EXCNT+1
18 G:EXCNT=1 FMT1 ;Only out of FMT
19 K OUT
20 S FMT="F"
21 ;
22 ;** FMT1 drops into from FMT or jumps into from FMT+3
23FMT1 S ^TMP($J,"NEW",EXMNM)=+Y_U_$S(EXCNT=1:"F",1:FMT)_U_EXMDA K Y H 1 W @FF,!!! G EXMSEL ;1st exam is 'full'
24 ;
25EXMDIS K %,%Y,DIE,DIC G:$D(DVBCLCKD) EXMSEL
26 I '$D(^TMP($J,"NEW")) W !!,*7,"You have not selected any exams.",!,"Do you want to try again" S %=1 D YN^DICN K OUT S:%=2 OUT=1 Q:$D(OUT) G:%=1 EXMHD I $D(DTOUT) S OUT=1 Q
27 I $D(%Y) I %Y["?" W !!,"Enter Y to select more exams or N to abort adding exams to this request.",!! G EXMDIS
28 I $D(%),%'=1 S OUT=1 Q
29 W @FF,!!,"You have selected:",!! S EXMNM=""
30 F JY=0:1 S EXMNM=$O(^TMP($J,"NEW",EXMNM)) Q:EXMNM="" W ?5,EXMNM,!
31 S DIR(0)="YA"
32 S DIR("A")=$S(JY'>1:"Is this exam",1:"Are these exams")_" correct? "
33 S DIR("B")="NO"
34 D ^DIR
35 K DIR
36 I Y K Y G EXMLOG
37 I $D(DIRUT) K Y,DIROUT S OUT=1 Q
38EXMOD ;drop into
39 I Y=0 K DIC,DIR,Y S DIC(0)="AEQM",DIC("A")="Enter EXAM to delete: ",DIC="^DVB(396.6,",DIC("S")="I $D(^TMP($J,""NEW"",$P(^(0),U,1)))"
40 ;
41EXMOD1 W @FF,!!! K OUT D ^DIC
42 S:$D(DTOUT) OUT=1 Q:$D(OUT)
43 G:X=""!(X=U) EXMASK ;Only out of EXMOD1
44 S EXMNM=$P(^DVB(396.6,+Y,0),U,1)
45 I +Y>0&($D(^TMP($J,"NEW",EXMNM))) K ^TMP($J,"NEW",EXMNM) W:$X>50!($X<10) ! W " Ok ..." S EXCNT=EXCNT-1 H 2 G EXMOD
46 G EXMOD1
47 ;
48EXMASK K DIC
49 W @FF,!!,"Want to add more exams"
50 S %=1 D YN^DICN G:%=1 EXMHD ;add exams
51 I $D(DTOUT) S OUT=1 Q
52 I $D(%Y),%Y["?" W !!,"Enter Y to add more exams or N to go on and log existing selections." D CONTMES^DVBCUTL4 G EXMASK
53 G EXMDIS
54 ;
55EXMLOG W !! S EXMNM="" K DR,OUT
56 N DVBCLCKD
57 F DVBCJ=0:0 S EXMNM=$O(^TMP($J,"NEW",EXMNM)) Q:EXMNM="" S X=$$EXAM^DVBCUTL4 S:X=0 DVBCLCKD=1 Q:$D(DVBCLCKD) D EXMLOG1^DVBCUTL4 Q:$D(OUT)
58 I $D(DTOUT) S OUT=1 D ROLLBCK^DVBCUTL4
59 Q:$D(OUT)
60 W:$D(DVBCLCKD) !!," Another user adding exams now...try again later."
61 R:$D(DVBCLCKD) !," PRESS [Return] TO CONTINUE...",DVBCCONT:DTIME
62 I $D(DVBCLCKD) D ROLLBCK^DVBCUTL4 G EXMDIS
63 I $P(^DVB(396.3,REQDA,0),U,2)'[DT S DR="23.3///NOW;23.4////"_DUZ,(DIC,DIE)="^DVB(396.3,",DA=REQDA D ^DIE ;no edit if requested today
64 D ^DVBCBUL1 W !
65 I '$D(OUT) S DIR("A")="Do you want to print worksheets ",DIR("A",1)="Worksheets should be sent to a printer.",DIR(0)="Y",DIR("?",1)="Enter Y to print worksheets for items just entered or",DIR("?")="N to skip." D ^DIR Q:Y=0!(Y=U)
66 D ^DVBCADE1
67 Q
Note: See TracBrowser for help on using the repository browser.