source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGSAUTL.m@ 1259

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

initial load of WorldVistAEHR

File size: 4.6 KB
Line 
1DGSAUTL ;ALB/MTC - SHARING AGREEMENTS UTILITY FUNCTIONS ; 16 JAN 97
2 ;;5.3;Registration;**114,194,216*****;Aug 13, 1993
3 ;
4 Q
5 ;
6EN(ORG) ;-- Entry point to Add/Edit Sharing Agreement Sub-Categories
7 ;
8 ; ORG - This parameter specifies the orginating process
9 ; "SD" - Appointment Type, "DG" - Admitting Regulation
10 ;
11 ;-- get the appropriate Admitting Reg or Appoitment Type
12 N DGAPT,DGCAT
13 ;
14 S DGAPT=$$GET(ORG)
15 ;-- if no selection quit
16 I DGAPT'>0 G ENQ
17 ;-- get category
18 S DGCAT=$$CAT(ORG)
19 I DGCAT'>0 G ENQ
20 ;-- put it all together
21 D GOGO(ORG,DGAPT,DGCAT)
22ENQ ;
23 Q
24 ;
25GOGO(ORG,ATR,CAT) ;-- This function does something
26 ;
27 I ORG=""!(ATR'>0)!(CAT'>0) G GOGOQ
28 ;
29 N DGX,DA
30 S DGX=$S(ORG="SD":"AT",1:"AR"),DIC("V")=$S(ORG="SD":"I +Y(0)=409.1",1:"I +Y(0)=43.4")
31 S DA=$O(^DG(35.1,DGX,+ATR,+CAT,0))
32 I DA D
33 . N DGEDMODE S DIE="^DG(35.1,",DR="[DGSHARESUB]" D ^DIE
34 E D
35 .S X=+ATR_";"_$S(ORG="SD":"SD(409.1,",1:"DIC(43.4,")
36 . S (DIC,DIK)="^DG(35.1,",DIC(0)="L",DLAYGO=35.1
37 . S DIC("DR")=".02////"_+CAT_";.03"
38 .K DD,DO D FILE^DICN
39 ;
40GOGOQ K DIE,DIC
41 Q
42 ;
43GET(ORG) ;-- This function will get the appropriate App Type or Admit Reg
44 N DGX
45 S:ORG="SD" DGX=$$GETAT
46 S:ORG="DG" DGX=$$GETAR
47 Q DGX
48 ;
49GETAT() ;-- get appointment type
50 K DIC,Y
51 S DIC="^SD(409.1,"
52 S DIC("S")="I +$P(^(0),U,3)=0"
53 S DIC(0)="AEZNQ"
54 D ^DIC
55 K DIC
56 Q $G(Y)
57 ;
58GETAR() ;-- get admitting regulation
59 N DIC,Y
60 S DIC="^DIC(43.4,"
61 S DIC("S")="I +$P(^(0),U,4)=0"
62 S DIC(0)="AEZNQ"
63 D ^DIC
64 K DIC
65 Q $G(Y)
66 ;
67CAT(DGORG) ;
68 N DIC,Y
69 ;-- get category from 35.2
70 S DIC="^DG(35.2,"
71 S DIC(0)="SLAEZQ"
72 D ^DIC
73 K DIC
74 Q $G(Y)
75 ;
76HLP ;-- help for Sub-Category file
77 ;
78 I '$D(DGAPT)!('$D(DGORG)) G HLPQ
79 ;
80 N DGX,DGI,DGJ
81 S DGJ=1
82 S DGX=$S(DGORG="SD":"AT",1:"AR")
83 S DGI=0 F S DGI=$O(^DG(35.1,DGX,+DGAPT,DGI)) Q:'DGI S DGK=$O(^(DGI,0)) D
84 . I DGORG="SD" D
85 .. I DGJ W !,"APPOINTMENT TYPE :",$P(DGAPT,U,2),!,?5,"CATEGORY :" S DGJ=0
86 . I DGORG="DG" D
87 .. I DGJ W !,"VA ADMITTING REGULATION :",$P(DGAPT,U,2),!,?5,"CATEGORY :" S DGJ=0
88 . W !,?10,$P(^DG(35.2,$P(^DG(35.1,DGK,0),U,2),0),U),?35,$S($P(^DG(35.1,DGK,0),U,3)=1:"ACTIVE",1:"INACTIVE")
89HLPQ ;
90 Q
91 ;
92ADCAT(ADCAT) ;-- This function will prompt the user for the category
93 ; associated with the admitting regulation selected.
94 ;
95 N RESULT,DGSA
96 S RESULT=$$SUB(ADCAT,1,$P($G(^DGPM(+$G(DA),"PTF")),U,4))
97 Q RESULT
98 ;
99GETSA(ATAR,SOURCE,ACTIVE) ;-- This function will build the DGSA array containing all the
100 ; sub-categories associated with an admitting reg.
101 ;
102 ;
103 Q:'$G(ATAR)
104 N DGX,DGY
105 S DGY=1,DGX=0 F S DGX=$O(^DG(35.1,$S(SOURCE=1:"AR",1:"AT"),ATAR,DGX)) Q:'DGX D
106 . N DGSCREEN S DGSCREEN=1 I $G(ACTIVE) S DGSCREEN=+$O(^(DGX,0)),DGSCREEN=$P($G(^DG(35.1,DGSCREEN,0)),U,3)
107 . I DGSCREEN S DGSA(1,DGX)=DGX_U_$P($G(^DG(35.2,DGX,0)),U)
108 Q
109 ;
110SUB(ATAR,SOURCE,DEFAULT) ;-- This function will check and prompt for sharing
111 ; agreement sub-categories associated with either an Admitting Reg
112 ; or a Appointment Type.
113 ;
114 ; INPUT: ATAR - IEN if Admitting Reg or Appointment Type
115 ; SOURCE - (1:ADT,2:SCHEDULING)
116 ; DEFALUT - IEN from file 35.2
117 ; OUTPUT: IEN of file 35.2^Name
118 ;
119 ;
120 N RESULT,ALLEL,EMP,X,DGDEF,Y
121 ;
122 ;-- get eligility codes
123 D GETSA(ATAR,SOURCE,1)
124 S DGDEF=$P($G(^DG(35.2,+$G(DEFAULT),0)),U)
125 I DGDEF'="" S DGDEF=DEFAULT_U_DGDEF
126 ;
127 S RESULT=""
128 I '$D(DGSA) G SUBQ
129 S X=0,X=$O(DGSA(1,X))
130 I '$O(DGSA(1,X)) S RESULT=DGSA(1,X) G SUBQ
131 ;-- if no default set default to first entry
132 I DGDEF="" S DGDEF=DGSA(1,X)
133 ;
134DISP ;-- display choices
135 ;
136 S ALLEL=""
137 ;-- get the name of the Admitting Reg or Appointment Type
138 I SOURCE=1 S DGNAME=$P($G(^DIC(43.4,ATAR,0)),U)
139 E S DGNAME=$P($G(^SD(409.1,ATAR,0)),U)
140 ;
141 W !,"THE ["_DGNAME_$S(SOURCE=1:"] ADMITTING REGULATION",1:"] APPOINTMENT TYPE")
142 W !,"HAS THE FOLLOWING SUB-CATEGORIES DEFINED."
143 S X="" F S X=$O(DGSA(1,X)) Q:'X D
144 . W !?5,$P(DGSA(1,X),U,2)
145 . S ALLEL=ALLEL_U_$P(DGSA(1,X),U,2)
146 ;
147 ;-- prompt for sub-categories
148 ;
1491 W !,"ENTER THE SUB-CAT FOR THE ["_DGNAME_$S(SOURCE=1:"] ADMITTING REG",1:"] APPT TYPE")_": "_$P(DGDEF,U,2)_"// "
150 R X:DTIME
151 ;-- if timeout
152 G SUBQ:'$T
153 ;-- if ^
154 G SUBQ:X[U
155 ;-- if default (primary) quit
156 I X="" S RESULT=DGDEF G SUBQ
157 ;-- find eligibility
158 S X=$$UPPER^VALM1(X)
159 G DISP:X["?",1:ALLEL'[(U_X)
160 N CNT,RES S CNT=0
161 S EMP=X ;_$P($P(ALLEL,U_X,2),U) ;W $P($P(ALLEL,U_X,2),U)
162 S X="" F S X=$O(DGSA(1,X)) Q:X'>0 D
163 . I $E($P(DGSA(1,X),U,2),1,$L(EMP))=EMP S CNT=CNT+1,(RES(CNT),RESULT)=X_U_$P(DGSA(1,X),U,2)
164 W:CNT=1 $P($P(ALLEL,U_EMP,2),U) I CNT>1 D G 1:(('RESULT)&(X'[U))
165 .N I F I=1:1:CNT W !?5,I_" "_$P(RES(I),U,2)
166 .W !,"CHOOSE 1 - "_CNT_": "
167 .S RESULT="" R X:DTIME I $D(RES(+X)) S RESULT=RES(+X) W " "_$P(RES(+X),U,2)
168SUBQ ;
169 K DGSA
170 Q +RESULT
171 ;
Note: See TracBrowser for help on using the repository browser.