source: WorldVistAEHR/trunk/r/PATIENT_DATA_EXCHANGE-VAQ/VAQREQ04.m@ 1495

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

initial load of WorldVistAEHR

File size: 4.0 KB
Line 
1VAQREQ04 ;ALB/JFP - PDX, REQUEST PATIENT DATA, ASK SEGMENT;01MAR93
2 ;;1.5;PATIENT DATA EXCHANGE;;NOV 17, 1993
3EP ; -- Entry point, second level of loop in VAQREQ03
4 ; NOTE: PDX*MIN is hard coded in this routine
5 ; - Called from VAQREQ03
6 ; - Calls help routine VAQREQ09
7 ;
8REQ ; -- Request segment
9 N DIRUT,DTOUT,DUOUT,X,I,N,L
10 N GRPDA,SEGDA,SEGMNU,SEGNODE,SEGNO,SEGNME,GTYPE,GDUZ,GRP
11 ;
12DRIVER ; -- Driver loop
13 I $D(^TMP("VAQSEG",$J,DOMAIN)) D LISTS ; -- displays segments on edit
14 F D ASKSEG Q:$D(DIRUT)
15 ; -- Cleanup and exit
16 K DIRUT,DTOUT,DUOUT,X,I,N,L
17 K SEGDA,SEGMNU,SEGNODE,SEGNO,SEGNME,GTYPE,GDUZ,GRP,GRPDA
18 QUIT
19 ;
20ASKSEG ; -- Prompts for segments
21 ; -- Sets default segment to PDX*MIN, Minimum patient information
22 ; Note: PDX*MIN is hard coded in this routine, if this mnuemonic
23 ; changes, the routine must change (ASKSEG+3)
24 ;
25 I '$D(^TMP("VAQSEG",$J,DOMAIN,"PDX*MIN")) D
26 .S SEGNO="",SEGNO=$O(^VAT(394.71,"C","PDX*MIN",SEGNO))
27 .S SEGNME=$P($G(^VAT(394.71,SEGNO,0)),U,1)
28 .S ^TMP("VAQSEG",$J,DOMAIN,"PDX*MIN")=SEGNO_"^"_SEGNME
29 ;
30 ; -- Call to Dir to request segments
31 S POP=0
32 S DIR("A")=" Enter Segment: "
33 S DIR(0)="FAO^1:30"
34 S DIR("?")="^D HLPSEG1^VAQREQ09"
35 S DIR("??")="^D HLPSEG2^VAQREQ09"
36 W ! D ^DIR K DIR Q:$D(DIRUT)
37 S X=Y
38 I X="*L" D LISTS Q:POP
39 I $E(X,1,1)="-" D DELSEG Q:POP
40 I $E(X,1,2)'="G." D SEG Q:POP
41 I $E(X,1,2)="G." D GSEG Q:POP
42 QUIT
43 ;
44SEG ; -- Dic lookup to verify segment in file 394.71
45 S DIC="^VAT(394.71,",DIC(0)="EMQZ"
46 D ^DIC K DIC I $D(DTOUT)!$D(DUOUT)!(Y<0) S POP=1 QUIT
47 S SEGNME=$P(Y(0),U,1),SEGMNU=$P(Y(0),U,2)
48 S SEGDA="",SEGDA=$O(^VAT(394.71,"C",SEGMNU,SEGDA))
49 S HSCOMPND=$$HLTHSEG^VAQDBIH1(SEGMNU,0)
50 I $P(HSCOMPND,U,1)'=0 D EP^VAQREQ11 ; -- Time and occurrence
51 D FLESEG
52 QUIT
53 ;
54GSEG ; -- Dic lookup to verify segment group name in file 394.84
55 S X=$P(X,".",2) ; -- strip off G.
56 S DIC="^VAT(394.84,"
57 S DIC(0)="EMQZ"
58 D ^DIC K DIC I $D(DTOUT)!$D(DUOUT)!(Y<0) S POP=1 QUIT
59 S GTYPE=$P(Y(0),U,2),GDUZ=$P(Y(0),U,3)
60 I (GTYPE="0")&(DUZ'=GDUZ) D QUIT
61 .W " ...Private group selected not associated with user"
62 .S POP=1
63 S GRP=$P(Y,U,2),GRPDA="",GRPDA=$O(^VAT(394.84,"B",GRP,GRPDA))
64 D S1
65 QUIT
66 ;
67S1 S SEGDA=""
68 F S SEGDA=$O(^VAT(394.84,GRPDA,"SEG","B",SEGDA)) Q:SEGDA="" D SETS
69 QUIT
70SETS S SEGNODE=$G(^VAT(394.71,SEGDA,0))
71 Q:SEGNODE=""
72 S SEGNME=$P(SEGNODE,U,1),SEGMNU=$P(SEGNODE,U,2)
73 S HSCOMPND=$$HLTHSEG^VAQDBIH1(SEGMNU,0)
74 I $P(HSCOMPND,U,1)'=0 D GROUP ; -- Time and occurrence
75 D FLESEG
76 QUIT
77 ;
78GROUP ; -- Sets time and occurrence limits for segment groups selected
79 S PARAMND=$G(^VAT(394.81,1,"LIMITS")) ; -- sets time & occ defaults
80 S TLDEF=$P(PARAMND,U,1)
81 S OLDEF=$P(PARAMND,U,2)
82 ;
83 S POS="",POS=$O(^VAT(394.84,GRPDA,"SEG","B",SEGDA,POS))
84 S GRPSEGND=$G(^VAT(394.84,GRPDA,"SEG",POS,0))
85 S TLIMIT=$P(GRPSEGND,U,4) I TLIMIT="" S TLIMIT=TLDEF
86 S OLIMIT=$P(GRPSEGND,U,5) I OLIMIT="" S OLIMIT=OLDEF
87 I $P(HSCOMPND,U,2)=0 S TLIMIT=""
88 I $P(HSCOMPND,U,3)=0 S OLIMIT=""
89 QUIT
90 ;
91FLESEG ; -- Loops thru domains filing segment data in ^TMP array
92 S LPDOM=""
93 F S LPDOM=$O(^TMP("VAQDOM",$J,LPDOM)) Q:LPDOM="" D FILE
94 QUIT
95 ;
96FILE ;
97 S:'$D(TLIMIT) TLIMIT=""
98 S:'$D(OLIMIT) OLIMIT=""
99 S ^TMP("VAQSEG",$J,LPDOM,SEGMNU)=SEGDA_"^"_SEGNME_"^"_TLIMIT_"^"_OLIMIT
100 QUIT
101 ;
102DELSEG ; -- Deletes selected segments
103 S POP=1,X=$P(X,"-",2)
104 I X="" W " ...No entries selected" QUIT
105 S ARRAY="^TMP(""VAQSEG"","_$J_","_$C(34)_DOMAIN_$C(34)_")"
106 S X=$$PARTIC^VAQUTL94(ARRAY,X)
107 I X=-1 W " ... Not Selected" QUIT
108 I X="PDX*MIN" W " ...required segment, not deleted" QUIT
109 I '$D(^TMP("VAQSEG",$J,DOMAIN,X)) W !,X," Not Selected" QUIT
110 K ^TMP("VAQSEG",$J,DOMAIN,X)
111 W " ...Segment Deleted"
112 QUIT
113 ;
114LISTS ; -- Displays a list segments selected for domain
115 S POP=1
116 I '$D(^TMP("VAQSEG",$J,DOMAIN)) W !!,"** NO SEGMENT(S) SELECTED" QUIT
117 W !!,"------------------------------ Segments Selected ------------------------------"
118 S N="" F L=0:1 S N=$O(^TMP("VAQSEG",$J,DOMAIN,N)) Q:N="" W:'(L#8) ! W ?L#8*10 W N
119 W !,"-------------------------------------------------------------------------------"
120 W ! QUIT
121 ;
122END ; -- End of code
123 QUIT
Note: See TracBrowser for help on using the repository browser.