source: WorldVistAEHR/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCLOGE.m@ 1710

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

initial load of WorldVistAEHR
File size: 4.3 KB
RevLine 
[613]1DVBCLOGE ;ALB/GTS-557/THM-SET UP C&P EXAM ; 5/10/91 8:55 AM
2 ;;2.7;AMIE;;Apr 10, 1995
3 ;if $D(OUT), request deleted - exams must be completed
4 ;
5EXMHD K OUT N DVBARQDT,DVBADT,DVBADA
6 W @FF,?(IOM-$L(HD2)\2),HD2
7 W !!,"Please select the exams for ",$P(PNAM,",",2,99)," ",$P(PNAM,",",1)
8 W !,"Use ? to see a list of exams available for selection.",!!
9 I $D(^DVB(396.3,REQDA,5)),($P(^DVB(396.3,REQDA,0),"^",10)="E"&(+$P(^DVB(396.3,REQDA,5),"^",1)'>0)) DO
10 .S TVAR(1,0)="0,0,0,1,0^NOTE: This request has a priority of Insufficient without a link"
11 .S TVAR(2,0)="0,8,0,1:1,0^to a completed request."
12 .S TVAR(3,0)="0,0,0,1:2,0^Use care to select the proper exam(s) to return as insufficient."
13 .D WR^DVBAUTL4("TVAR")
14 .K TVAR
15 I '$D(^DVB(396.3,REQDA,5))&($P(^DVB(396.3,REQDA,0),"^",10)="E") DO
16 .S TVAR(1,0)="0,0,0,1,0^NOTE: This request has a priority of Insufficient without a link"
17 .S TVAR(2,0)="0,8,0,1:1,0^to a completed request."
18 .S TVAR(3,0)="0,0,0,1:2,0^Use care to select the proper exam(s) to return as insufficient."
19 .D WR^DVBAUTL4("TVAR")
20 .K TVAR
21 ;
22EXMSEL K DIC,OUT,DVBAQT I $D(DVBCLCKD) Q
23 S DVBARQDT=$P(^DVB(396.3,REQDA,0),U,2)
24 I $D(^DVB(396.3,REQDA,5)),(+$P(^DVB(396.3,REQDA,5),U,1)>0) DO
25 .S DVBAINDA=+$P(^DVB(396.3,REQDA,5),U,1) ;**Exam Scr for Insuff 2507'S
26 .S DIC("S")="I $D(^DVB(396.4,""ARQ"_DVBAINDA_""",Y))"
27 S:'$D(DIC("S")) DIC("S")="I $P(^(0),U,5)'=""I"""
28 S DIC="^DVB(396.6,"
29 S DIC(0)="AEQM",DIC("A")="Select EXAM: " D ^DIC
30 S:$D(DTOUT) OUT=1 D:$D(OUT) KVARS Q:$D(OUT)
31 G:X=""!(X=U) EXMDIS ;Only out of EXMSEL
32 I +Y>0 S EXMNM=$P(^DVB(396.6,+Y,0),U,1),EXMPTR=+Y
33 I +Y<0 W " ???" G EXMSEL
34 I $D(^TMP($J,"NEW",EXMNM)) W " Duplicate - ignored",!,*7 G EXMSEL
35 I $D(^DVB(396.4,"APS",DFN,EXMPTR,"O"))>0 W *7," -- already ON FILE",!
36 I $D(^DVB(396.4,"APS",DFN,EXMPTR,"O"))>0 S DVBAQT=1
37 G:$D(DVBAQT) EXMSEL
38 S ^TMP($J,"NEW",EXMNM)=+Y K Y G EXMSEL
39 ;
40EXMDIS W @FF,!! K %,%Y,DIE,DIC G:$D(DVBCLCKD) EXMSEL
41 I '$D(^TMP($J,"NEW")) W !!,*7,"You have not selected any exams.",!,"Do you want to try again" S %=1 D YN^DICN D:%=1 KVARS G:%=1 EXMHD I $D(DTOUT) S OUT=1 D KVARS Q
42 I $D(%Y) I %Y["?" W !!,"Enter Y to go back and select exams or N to DELETE the entire request",!,"as well as any exams selected." D CONTMES^DVBCUTL4 G EXMDIS
43 I $D(%) I %'=1 S OUT=1 D KVARS Q
44 W !!,"You have selected these exams:",!! S EXMNM="" F JY=0:1 S EXMNM=$O(^TMP($J,"NEW",EXMNM)) Q:EXMNM="" W ?5,EXMNM,!
45 W !,$S(JY'>1:"Is this exam",1:"Are these exams")," correct"
46 S %=2 D YN^DICN G:%=1 EXMLOG ;Only out of EXMDIS
47 I $D(DTOUT) S OUT=1 D KVARS Q
48 I $D(%Y),%Y["?" W !,"Enter Y to go ahead and log the selected exams or N to modify the list." D CONTMES^DVBCUTL4 G EXMDIS
49 ;
50EXMOD ;drop into - correct exams
51 I $D(%),%=2 W @FF,!!!
52 S DIC(0)="AEQM",DIC("A")="Enter EXAM to delete: "
53 S DIC="^DVB(396.6,",DIC("S")="I $D(^TMP($J,""NEW"",$P(^(0),U,1)))"
54 ;
55EXMOD1 K OUT D ^DIC
56 S:$D(DTOUT) OUT=1 D:$D(OUT) KVARS Q:$D(OUT)
57 G:X=""!(X=U) EXMASK ;Only out of EXMOD1
58 S EXMNM=$P(^DVB(396.6,+Y,0),U,1)
59 I +Y>0&($D(^TMP($J,"NEW",EXMNM))) K ^TMP($J,"NEW",EXMNM) W " Ok ..." H 1 G EXMOD1
60 G EXMOD1
61 ;
62EXMASK W @FF,!!,"Want to add more exams"
63 S %=1 D YN^DICN G:%=1 EXMSEL ;select more exams
64 I $D(DTOUT) S OUT=1 D KVARS Q
65 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
66 G EXMDIS ;display exams
67 ;
68EXMLOG W !! S EXMNM="" K DR
69 D STM^DVBCUTL4
70 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 Q:$D(OUT)
71 S XRTN=$T(+0)
72 D SPM^DVBCUTL4
73 W:$D(DVBCLCKD) !!," Another user adding exams now...try again later."
74 R:$D(DVBCLCKD) !," PRESS [Return] TO CONTINUE...",DVBCCONT:DTIME
75 I $D(DVBCLCKD) D ROLLBCK^DVBCUTL4 G EXMDIS
76 I $D(OUT) D KVARS Q
77 H 2 K DA S DA=REQDA
78 W @IOF,!,"Please enter any remarks for this request:",!!!
79 S DR="23",DIE="^DVB(396.3," D ^DIE H 1
80 K DIC,DIE,DR,EXMNM,DVBCDEL,Y,X,EXMPTR D KVARS
81 Q
82 ;
83EXMLOG1 ;called by EXMLOG
84 K OUT,DD,DO S (DIC,DIE)="^DVB(396.4,",DIC(0)=""
85 S DIC("DR")=".02////^S X=REQDA;.03////^S X=$P(^TMP($J,""NEW"",EXMNM),U,1);.04////O"
86 D FILE^DICN
87 I $D(Y),+Y>0 W:$X>50 ! W:$X>40&($L(EXMNM)>30) ! W EXMNM_" -added, "
88 I $D(Y),+Y<0 W *7,"Exam addition error ! " S OUT=1
89 D INSXM^DVBCUTA1
90 I $D(DTOUT) W *7,"Exam addition error ! " S OUT=1 D ROLLBCK^DVBCUTL4
91 Q
92 ;
93KVARS ;Kill this routines variables
94 K DVBARQDT,DVBADT,DVBADA,DVBAQT,DVBAINDA
95 Q
Note: See TracBrowser for help on using the repository browser.