source: FOIAVistA/trunk/r/PATIENT_DATA_EXCHANGE-VAQ/VAQREQ03.m@ 761

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

initial load of FOIAVistA 6/30/08 version

File size: 3.5 KB
Line 
1VAQREQ03 ;ALB/JFP - PDX, REQUEST PATIENT DATA, ASK DOMAIN/SEGMENT;01MAR93<<= NOT VERIFIED > [ 10/18/96 9:19 AM ]
2 ;;1.5;PATIENT DATA EXCHANGE;**22,30**;NOV 17, 1993
3EP ; -- Main entry point
4 ; - Called from VAQREQ02
5 ; - Calls ask segment routine VAQREQ04
6 ; - Calls help routine VAQREQ09
7 ;
8REQ ; -- Request domain
9 N L,N,X,POP,INSTDA,DOMAIN,STNO,INST,DOMDA,FLAGS
10 N DIRUT,DTOUT,DUOUT
11 ;
12 S SEGNO="",SEGNO=$O(^VAT(394.71,"C","PDX*MIN",SEGNO))
13 S SEGNME=$P($G(^VAT(394.71,SEGNO,0)),U,1)
14 ;
15 F D ASKDOM Q:$D(DIRUT)
16 QUIT
17 ;
18ASKDOM ; -- Call to Dir to request domain
19 D:$D(^TMP("VAQSEG",$J)) LISTD
20 K ^TMP("VAQDOM",$J)
21 S POP=0
22 S DIR("A")="Enter Domain: "
23 S DIR(0)="FAO^1:30"
24 S DIR("?")="^D HLPDOM1^VAQREQ09"
25 S DIR("??")="^D HLPDOM2^VAQREQ09"
26 W ! D ^DIR K DIR Q:$D(DIRUT)
27 S X=Y
28 I X="*L" D LISTD Q:POP
29 I $E(X,1,1)="-" D DELDOM Q:POP
30 I $E(X,1,2)'="G." D DOM Q:POP
31 I $E(X,1,2)="G." D GDOM Q:POP
32 D EP^VAQREQ04 ; -- ask segments
33 QUIT
34 ;
35DOM ; -- Dic lookup to verify domain in file 4.2
36 S DIC=4.2,DIC(0)="EMQZ"
37 D ^DIC K DIC I $D(DTOUT)!$D(DUOUT)!(Y<0) S POP=1 QUIT
38 ; -- Check for closed domains
39 S FLAGS=$P(Y(0),U,2)
40 I FLAGS["C" W $C(7)," ...Domain is closed" S POP=1 QUIT
41 ;
42 S STNO=$P(Y(0),U,13),DOMAIN=$P(Y,U,2)
43 I STNO="" W " ...Domain entered does not have a station number" S POP=1 QUIT
44 S INSTDA=$O(^DIC(4,"D",STNO,""))
45 I INSTDA="" W " ...Domain does not have a valid station number" S POP=1 QUIT
46 S INST=$P(^DIC(4,INSTDA,0),U,1)
47 S ^TMP("VAQSEG",$J,DOMAIN,"PDX*MIN")=SEGNO_"^"_SEGNME
48 S ^TMP("VAQDOM",$J,DOMAIN)=""
49 QUIT
50 ;
51GDOM ; -- Dic lookup to verify domain group name in file 394.83
52 S X=$P(X,".",2) ; -- strip off G.
53 S DIC="^VAT(394.83,"
54 S DIC(0)="EMQZ"
55 D ^DIC K DIC I $D(DTOUT)!$D(DUOUT)!(Y<0) S POP=1 QUIT
56 S GRP=$P(Y,U,2),GRPDA="",GRPDA=$O(^VAT(394.83,"B",GRP,GRPDA))
57 D G1
58 QUIT
59 ;
60G1 S (INSTDA,DOMDA)=""
61 F I=1:1 S INSTDA=$O(^VAT(394.83,GRPDA,"FAC","A-OUTGRP",INSTDA)) Q:'INSTDA D G2
62 QUIT
63G2 F I=1:1 S DOMDA=$O(^VAT(394.83,GRPDA,"FAC","A-OUTGRP",INSTDA,DOMDA)) Q:'DOMDA D SETG
64 QUIT
65 ;
66SETG ; --
67 Q:'$$OKDOM(GRPDA,INSTDA,DOMDA)
68 S INST=$P($G(^DIC(4,INSTDA,0)),U,1)
69 S DOMAIN=$P($G(^DIC(4.2,DOMDA,0)),U,1)
70 S ^TMP("VAQSEG",$J,DOMAIN,"PDX*MIN")=SEGNO_"^"_SEGNME
71 S ^TMP("VAQDOM",$J,DOMAIN)=""
72 QUIT
73OKDOM(GRPDA,INSTDA,DOMDA) ;
74 N REC
75 S REC=$G(^DIC(4.2,DOMDA,0))
76 Q:$P(REC,U,2)'["C" 1
77 ; Domain is closed. Tell the user and delete the remote facility
78 ; record from the group.
79 W !!,"Domain ",$P(REC,U,1)," is closed."
80 N FDA,VIEN
81 S VIEN=$O(^VAT(394.83,GRPDA,"FAC","B",INSTDA,0)) Q:'VIEN
82 S FDA(394.831,VIEN_","_GRPDA_",",.01)="@"
83 D FILE^DIE("","FDA")
84 W !,"Because of that, Facility '",$P($G(^DIC(4,INSTDA,0)),U,1),"'"
85 W !,"has been deleted from Outgoing Group '",$P($G(^VAT(394.83,GRPDA,0)),U,1),"'."
86 Q 0
87 ;
88DELDOM ; -- Deletes domain & segments associated with domain
89 S POP=1,X=$E(X,2,99)
90 I X="" W !!,"** NO ENTRIES SELECTED" QUIT
91 S X=$$PARTIC^VAQUTL94("^TMP(""VAQSEG"","_$J_")",X)
92 I X=-1 W " ... Not Selected" QUIT
93 I '$D(^TMP("VAQSEG",$J,X)) W " ... ",X," Not Selected" QUIT
94 K ^TMP("VAQSEG",$J,X)
95 W " ...domain deleted and associated segments"
96 QUIT
97 ;
98LISTD ; -- Displays a list domains selected
99 S POP=1
100 I '$D(^TMP("VAQSEG",$J)) W !!,"** NO DOMAIN(S) SELECTED" QUIT
101 W !!,"------------------------------ Domains Selected ------------------------------"
102 S N="" F L=0:1 S N=$O(^TMP("VAQSEG",$J,N)) Q:N="" W:'(L#8) ! W ?L#8*40 W N
103 W !,"-------------------------------------------------------------------------------"
104 W ! QUIT
105 ;
106END ; -- End of code
107 QUIT
Note: See TracBrowser for help on using the repository browser.