source: FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCXFRA.m@ 635

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

initial load of FOIAVistA 6/30/08 version
File size: 4.8 KB
Line 
1DVBCXFRA ;ALB/GTS-557/THM-TRANSFER C&P REQUESTS ; 4/18/91 2:14 PM
2 ;;2.7;AMIE;;Apr 10, 1995
3 ;
4 D HOME^%ZIS K CORR S FF=IOF G EN
5 ;
6CORSEL I SEL=1 G EN
7 I SEL=2 G DOMAIN
8 I SEL=3 G EXAMS
9 I SEL=4 K CORR,EXAMS,X,Y,REQDA G EN
10 I SEL[U G EXIT
11 ;
12SET ;** EXAMS - Xfr all
13 S EXMNM=$P(^DVB(396.6,$P(^DVB(396.4,JJ,0),U,3),0),U,1)
14 I $P(^DVB(396.4,JJ,0),U,4)["X" W EXMNM," is CANCELED and cannot be transferred.",!,*7 Q
15 I $P(^DVB(396.4,JJ,0),U,4)="C" W EXMNM," is COMPLETED and cannot be transferred.",!,*7 Q
16 I $P(^DVB(396.4,JJ,0),U,4)="T" W EXMNM," has been TRANSFERRED and cannot be selected.",!,*7 Q
17 W !,EXMNM," is OK to transfer.",!!
18 S EXAMS=EXAMS_$P(^DVB(396.4,JJ,0),U,3)_U,XEXAMS(JJ)="",XMCNT=XMCNT+1
19 ;
20 ;** Set XMVAR(XMCNT)=$EXAM AMIE EXAM IFN^INSUFF REASON IFN
21 S XMVAR(XMCNT)="$EXAM "_$P(^DVB(396.4,JJ,0),U,3)_U_$S(+$P(^DVB(396.4,JJ,0),U,11)>0:$P(^DVB(396.94,$P(^DVB(396.4,JJ,0),U,11),0),U,1),1:"")
22 ;EXAMS for MailMan msg, XEXAMS sets exam status
23 ;XMVAR() add one exam/line to bulletin - Future
24 Q
25 ;
26EN W @FF,!,"Transfer C&P Exams",!!!!
27 K DVBAINSF S DIC="^DVB(396.3,",DIC(0)="AEQMZ",DIC("A")="Select VETERAN NAME: " D ^DIC K DIC G:X=""!(X=U) EXIT I +Y<0 W *7," ???" H 2 G EN
28 I $P(Y(0),U,18)'="P" W !!,*7,"This request does not have a PENDING status and may not be transferred.",!! H 3 G EN
29 I $P(Y(0),U,22)]"" W !!,*7,"This request was transferred in and CANNOT be transferred to any other site !",!! H 3 G EN
30 ;
31ENQUEST W !!!,"Is this the correct request" S %=2 D YN^DICN G:%<0 EXIT I %=2 H 1 G EN
32 I %=0 W !!,"Enter Y if the correct Veteran or N if not.",!! DO
33 .D CONTMES^DVBCUTL4
34 I %=0 G ENQUEST
35 K DVBAINSF
36 S REQDA=+Y,DFN=$P(Y,U,2),PNAM=$P(^DPT(DFN,0),U,1),SSN=$P(^(0),U,9)
37 S:$P(^DVB(396.3,REQDA,0),U,10)="E" DVBAINSF=""
38 I $D(CORR) G DISPLAY
39 ;
40DOMAIN W @FF,!,"Selection of transfer domain:",!!!!
41 S DIC("A")="Send to domain: ",DIC="^DIC(4.2,",DIC(0)="AEQM" D ^DIC G:X=""!(X=U) EXIT I +Y<0 W *7," ???" H 2 G EN
42 ;
43DOMQST W !!!,"Is this the correct domain" S %=2 D YN^DICN G:%<0 EXIT I %=2 H 1 G DOMAIN
44 I %=0 W !!,"Enter Y if the domain is correct or N to reselect." D CONTMES^DVBCUTL4 G DOMQST
45 S DOMNUM=$S($P(^DIC(4.2,+Y,0),U,3)]"":$P(^(0),U,3),1:+Y),DOMNAM=$P(^(0),U,1),DOMNUM1=+Y
46 I $D(CORR) G DISPLAY
47 ;
48EXAMS K XEXAMS W @FF,!,"Exam selection",!!!! S EXAMS="",XMCNT=0
49 F LPCNT=0:0 S LPCNT=$O(XMVAR(LPCNT)) Q:LPCNT="" K XMVAR(LPCNT)
50 W !!,"Do you want to transfer ALL exams" S %=2 D YN^DICN G:%<0 EXIT
51 I %=2 W !! G PART
52 I %=0 W !!,"Enter Y if you want to transfer all exams or N if not.",!! D CONTMES^DVBCUTL4 G EXAMS
53 W !!! F JJ=0:0 S JJ=$O(^DVB(396.4,"C",REQDA,JJ)) Q:JJ="" D SET
54 D PAUSE^DVBCUTL4
55 G @$S(EXAM]""&(Y):"DISPLAY",1:"EN")
56 ;
57PART W @FF,!,"Individual exam selection",!!!!
58 S Y=$$EXSRH^DVBCUTL4("Select EXAM TO TRANSFER: ","I $D(^DVB(396.4,""ARQ""_REQDA,+Y))") ;*Exam lookup function call
59 K DIC G:X=""&(EXAMS]"") DISPLAY G:X=U EXIT
60 I +Y<0 W *7,!!,"No exams have been selected for transfer." D CONTMES^DVBCUTL4 G EN
61 I $P(^DVB(396.4,+Y,0),U,4)["X" W !!,"This exam is CANCELED and cannot be transferred.",*7,!! D CONTMES^DVBCUTL4 G PART
62 I $P(^DVB(396.4,+Y,0),U,4)="C" W !!,"This exam has been COMPLETED and cannot be transferred.",!!,*7 D CONTMES^DVBCUTL4 G PART
63 I $P(^DVB(396.4,+Y,0),U,4)="T" W !!,"This exam has been TRANSFERRED and cannot be selected.",!!,*7 D CONTMES^DVBCUTL4 G PART
64PART1 W !!!,"Is this the correct exam" S %=2 D YN^DICN G:%<0 EXIT I %=2 G EXAMS
65 I %=0 W !!,"Enter Y if all is correct or N to reselect another exam." D CONTMES^DVBCUTL4 G PART1
66 I EXAMS[$P(^DVB(396.4,+Y,0),U,3)_U DO
67 .W !!,*7,"You have already selected this exam for transfer."
68 .D CONTMES^DVBCUTL4
69 I EXAMS[$P(^DVB(396.4,+Y,0),U,3)_U G PART
70 S EXAMS=EXAMS_$P(^DVB(396.4,+Y,0),U,3)_U,XEXAMS(+Y)="",XMCNT=XMCNT+1
71 D SETXMVR^DVBCXUTL ;** Set XMVAR(XMCNT)
72 W !! G PART
73 ;
74DISPLAY I EXAMS="" W @FF,!!!,"No exams have been selected for transfer.",!! D PAUSE^DVBCUTL4 G EN
75 W @FF,!!,"You have selected the following:",!!!,"Veteran name: ",PNAM,?50,"SSN: ",SSN,!,"Request date: " S Y=$P(^DVB(396.3,REQDA,0),U,2) X ^DD("DD") W Y,!!!,"Exams selected for transfer:",!!
76 F I=1:1 S X=$P(EXAMS,U,I) Q:X="" W $P(^DVB(396.6,X,0),U,1),"; " I $X>45 W !?2
77 ;
78YN K DA(1) W !!!,"Is this information correct" S %=2 D YN^DICN I %<0 K EXAMS,REQDA,X,DIC,DA,Y,DVBAINSF,XMCNT F LPCNT=0:0 S LPCNT=$O(XMVAR(LPCNT)) Q:LPCNT="" K XMVAR(LPCNT)
79 I %<0 K LPCNT G EN
80 I %=0 W !!,"Answer YES if correct and NO if not" G YN
81 I %=1 W !!,"One moment please ... "
82 ;
83DISPLAY1 ;
84 K CORR I %=2 S CORR=1 W @FF,!!,"Select part to correct:",!!!,"1. Veteran name",!,"2. Domain",!,"3. Exams",!,"4. All parts",!!,"Selection: " R SEL:DTIME G:'$T!(SEL[U) EXIT
85 I $D(CORR) I (SEL'?1N)!(+SEL'>0)!(+SEL'<5)!(SEL["?") W *7,!!,"Must be a number from 1 to 4. " D CONTMES^DVBCUTL4 G DISPLAY1
86 I $D(CORR) G CORSEL
87 D INREAS^DVBCXUTL
88 G ^DVBCXFRB
89 ;
90EXIT D CLRVAR^DVBCXUTL
91 D KILLVRS^DVBCXUTL G KILL^DVBCUTIL
Note: See TracBrowser for help on using the repository browser.