source: WorldVistAEHR/trunk/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCASV.m@ 1036

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

initial load of WorldVistAEHR
File size: 9.2 KB
RevLine 
[613]1GMRCASV ;SLC/KCM,DLT - Build ^TMP("GMRCS" of Svc(s)/Specialties ; 11/25/2000
2 ;;3.0;CONSULT/REQUEST TRACKING;**1,12,18,22,53**;DEC 27, 1997;Build 3
3 ; This routine invokes IA #2426
4 ;
5ASRV ;Ask for service/specialty group {output} GMRCDG,GMRCBUF,GMRCACT,^TMP("GMRCS",$J,^TMP("GMRCSLIST",$J
6 K GMRCQUT
7 N GMRCSEL
8 D SERV0 D:GMRCDG SERV1
9 K W,X,Y Q
10SERV0 ;Assume that the lookup must begin with ALL SERVICES, or value of GMRCSVNM
11 ;GMRCASV=the ask prompt text
12 ;GMRCSVNM=text to use for default name
13 S GMRCDG=0
14 S:$G(GMRCASV)["Forward" GMRCTO=1
15 F D ASKPRMPT S:X["^^" DIROUT=1 S:X["^" GMRCQUT=1 Q:X["^" D @$S(X["?":"LISTALL",1:"LKUP") D:($L($G(GMRCSVNM))&GMRCDG) LISTSRV Q:GMRCDG
16 Q
17ASKPRMPT ;Write the prompt and do the Read to get the user text entered in X
18 W !!,$S($D(GMRCASV):GMRCASV,1:"Select Service/Specialty: ")_$S($L($G(GMRCSVNM)):GMRCSVNM,1:"ALL SERVICES")_"// "
19 R X:DTIME
20 I '$T S X="^"
21 I X'["^" S X=$S($G(GMRCASV)["Forward"&('$L(X)):"^",'$L(X):"ALL SERVICES",1:X) Q
22 Q
23SERV1 ;Create selected SERVICE ^TMP array of service information
24 ;If GMRCTO=1 then the BILD section will not include disabled or tracking services which the user cannot send to.
25 N GMRCDGT
26 S GMRCBUF=GMRCDG
27 I GMRCBUF>0 D
28 . K ^TMP("GMRCS",$J),^TMP("GMRCSLIST",$J)
29 . S GMRCDGT=0,GMRCSEL="BILD" D EN
30 . S GMRCGRP("NAM")=^GMR(123.5,GMRCBUF,0)
31 . S (GMRCDG,GMRCGRP("ROOT"))=GMRCBUF
32 . S GMRCGRP("NAM")=$S($L($P(GMRCGRP("NAM"),"^",3)):$P(GMRCGRP("NAM"),"^",3),1:$E($P(GMRCGRP("NAM"),"^"),1,5))
33 K GMRCSEQ,GMRCBUF
34 Q
35LKUP ;Ask the user for the service; use the value of x for lookup; branch to list on ??
36 ; Patch 18 added Identifier to 123.5 in place of DIC("W")
37 ; Remove commented line in next patch.
38 ;S DIC="^GMR(123.5,",DIC(0)="MNEQZ"
39 ;D ^DIC K DIC
40 ; Patch 53 added screen to prevent Forwarding to a Tracking Service
41 I $G(GMRCTO)=1 S DIC("S")="I ($$VALIDU^GMRCAU(Y,DUZ)&($P($G(^(0)),U,2)=2))!($P($G(^(0)),U,2)="""")!($P($G(^(0)),U,2)=1)"
42 S DIC="^GMR(123.5,",DIC(0)="MNEQZ",D="B^D"
43 D MIX^DIC1 K DIC
44 I '$D(Y(0)) D LISTALL Q
45 N W,GMRCEXCL I +$G(GMRCTO) D
46 . S W=Y(0),GMRCDG=+Y
47 . S GMRCEXCL=0 D EXCLUDE
48 . I GMRCEXCL=1 S GMRCSVNM=Y(0,0),GMRCEXCL=0 Q
49 . K GMRCSVNM ;Service selected is not a grouper for lookup
50 . I GMRCEXCL=9 S GMRCMSG="You have selected a disabled service!" D EXAC^GMRCADC(GMRCMSG) K GMRCMSG Q
51 . I GMRCEXCL=3 S GMRCMSG="You may not forward this Inter-facility Consult to another inter-facility consult service." D EXAC^GMRCADC(GMRCMSG) K GMRCMSG Q
52 . N GMRCDAD D CHECKDAD
53 . I GMRCEXCL=90 S GMRCMSG="You have selected a service that is not part of the ALL SERVICES hierarchy!",GMRCMSG(1)="Contact Consult ADPAC" D EXAC^GMRCADC(.GMRCMSG) K GMRCMSG Q
54 . ;I GMRCEXCL=9 S GMRCMSG="You have selected a service whose parent is disabled!" D EXAC^GMRCADC(GMRCMSG) K GMRCMSG Q
55 . I GMRCEXCL=2 S GMRCMSG="You have selected a service whose parent is a tracking service!",GMRCMSG(1)="You do not have authorization to send consults to this service." D EXAC^GMRCADC(.GMRCMSG) K GMRCMSG Q
56 . I GMRCEXCL=3 S GMRCMSG="You may not forward this Inter-facility Consult to another inter-facility consult service." D EXAC^GMRCADC(GMRCMSG) K GMRCMSG Q
57 I +$G(GMRCEXCL) S Y=0,GMRCDG=0
58 S:Y>0 GMRCDG=+Y ;falls to here when service is a grouper or not excluded
59 Q
60 ;
61LISTOPT ;called from option to list hierarchy
62 S %ZIS="Q"
63 D ^%ZIS I POP Q
64 I $D(IO("Q")) D QUEUE^GMRCASV1 D ^%ZISC,HOME^%ZIS Q
65 D PRTLST
66 D ^%ZISC,HOME^%ZIS
67 Q
68 ;
69PRTLST ;queued entry point or just print it
70 I $D(ZTQUEUED) S ZTREQ="@"
71 U IO
72 N GMRCPRT,GMRCPG,GMRCTO,GMRCDG,GMRCOUT
73 N DUOUT,DTOUT,DIROUT
74 S GMRCPG=0,GMRCPRT=1
75 D PAGE^GMRCASV1(.GMRCPG)
76 D LISTALL I $D(GMRCOUT) Q
77 I $Y>(IOSL-4) D READ I $D(GMRCOUT) Q
78 W !!,"Services not currently part of the Consults Hierarchy:"
79 N SERV S SERV=1
80 F S SERV=$O(^GMR(123.5,SERV)) Q:'SERV Q:$D(GMRCOUT) D
81 . I '$D(^GMR(123.5,"APC",SERV)) D
82 .. I $Y>(IOSL-4) D READ I $D(GMRCOUT) Q
83 .. W !,?3,$P(^GMR(123.5,SERV,0),U) I '$P(^(0),U,2) Q
84 .. N USE S USE=$P(^GMR(123.5,SERV,0),U,2)
85 .. W " ("
86 .. W $S(USE=1:"Grouper Only",USE=9:"Disabled",1:"Tracking Only")_")"
87 K GMRCDG D EXIT
88 Q
89LISTALL ;display LIST of Services in their hierarchy beginning with ALL SERVICES
90 S GMRCDG=$O(^GMR(123.5,"B","ALL SERVICES",0)) Q:'GMRCDG
91 S GMRCSEL="DISP" W:'$D(GMRCPRT) @IOF D EN
92 S GMRCDG=0 W !
93 Q
94LISTSRV ;display LIST of sub-services beginning with a selected service
95 S GMRC1=0,GMRCDG=$O(^GMR(123.5,"B",GMRCSVNM,0)) Q:'GMRCDG
96 S GMRCSEL="DISP" W @IOF D EN
97 S GMRCDG=0 W !
98 Q
99EN ;Setup Specialty groups entry: GMRCDG,GMRCSEL exit: GMRCGRP if GMRCSEL="BILD"
100 N GMRCSTK,PARENT,GMRCUSG,GMRCEXCL
101 S GMRCSTK=0,PARENT=0 ;beginning service logic
102 D @GMRCSEL Q:$D(DUOUT)!($D(DIROUT))!($D(GMRCOUT))
103EN1 ;GMRCSTK is used to manage the level of stacks under beginning service
104 S GMRCSTK=1,GMRCSTK(GMRCSTK)=GMRCDG_"^0",GMRCSTK(0)=0,GMRCMEM=0,GMRCNAM=""
105 F S GMRCNAM=$O(^GMR(123.5,+GMRCSTK(GMRCSTK),10,"AC",GMRCNAM)) D D @$S(+GMRCMEM'>0:"POP",1:"PROC") Q:GMRCSTK<1
106 . I $G(GMRCEXCL) S GMRCMEM=0 Q ;Exclude children of excluded parent
107 . I '$L(GMRCNAM) S GMRCMEM=0 ;No more 10th node children
108 . E S GMRCMEM=$O(^GMR(123.5,+GMRCSTK(GMRCSTK),10,"AC",GMRCNAM,""))
109 K DUOUT,GMRCMEM,GMRCNAM,GMRCSTK,GMRCSEL
110 Q
111POP ;Go back one level in service stack hierarchy and initialize exclude
112 S GMRCSTK=GMRCSTK-1,GMRCMEM=$P(GMRCSTK(GMRCSTK),"^",2),GMRCNAM=$P(GMRCSTK(GMRCSTK),"^",3),GMRCEXCL=0
113 Q
114PROC ;GMRCMEM is the member ien in the 10th node being processed
115 ;GMRCDG is the ien of file 123.5 being processed
116 ;GMRCNAM is the services name
117 S $P(GMRCSTK(GMRCSTK),"^",2)=GMRCMEM
118 S $P(GMRCSTK(GMRCSTK),"^",3)=GMRCNAM
119 Q:'$D(^GMR(123.5,+GMRCSTK(GMRCSTK),10,GMRCMEM,0)) ;ghost "AC" x-ref
120 S GMRCDG=$P(^GMR(123.5,+GMRCSTK(GMRCSTK),10,GMRCMEM,0),"^",1)
121 S PARENT=+GMRCSTK(GMRCSTK)
122 S W=$G(^GMR(123.5,GMRCDG,0))
123 I $G(GMRCTO)=1 S GMRCEXCL=0 D EXCLUDE S:GMRCEXCL=1 GMRCEXCL=0 ;Includes grouper only
124 D:'+$G(GMRCEXCL) @GMRCSEL G:($D(DUOUT)!$D(DIROUT)) EXIT
125 ;Initialize a stack level entry to process children of the multiple
126 S GMRCSTK=GMRCSTK+1,GMRCSTK(GMRCSTK)=GMRCDG_"^0",GMRCMEM=0,GMRCNAM=""
127 Q
128DISP ;Display individual entries alphabetically for each service as processed
129 Q:$D(GMRCOUT)
130 I $Y>(IOSL-4) D READ S:$D(DUOUT)!($D(DIROUT)) GMRCSTK=0 G:GMRCSTK=0 EXIT
131 S W=$G(^GMR(123.5,GMRCDG,0))
132 S GMRCUSG=$P(W,"^",2)
133 W !,?((GMRCSTK*2)),$S(GMRCUSG=9:"<",1:"")_$P(W,"^")_$S(GMRCUSG=9:">",1:"")_" "_$S(GMRCUSG=1:"(Grouper Only)",GMRCUSG=2:"(Tracking Only)",GMRCUSG=9:"<Disabled>",1:"")_" "_$S($G(^GMR(123.5,GMRCDG,"IFC")):"(Inter-facility)",1:"")
134 Q
135BILD ;The following logic will build an array for review for GUI
136 ;GMRCDGT=sequential number,GMRCDG=service pointer,
137 ;W=^GMR(123.5,GMRCDG,0),1st piece is name, 2nd piece usage
138 ;If GMRCTO=1 then services that only consults can be sent to will be
139 ;included with the exception of "grouper only" which keeps the
140 ;hierarchy in order.
141 N CHILD
142 S W=$G(^GMR(123.5,GMRCDG,0))
143 S ^TMP("GMRCS",$J,GMRCDG)=$P(W,"^")
144 S GMRCDGT=GMRCDGT+1
145 S CHILD=$O(^GMR(123.5,GMRCDG,10,0)) S CHILD=$S(+CHILD:"+",1:"")
146 S ^TMP("GMRCSLIST",$J,GMRCDGT)=GMRCDG_U_$P(W,"^")_U_PARENT_U_CHILD_U_$P(W,"^",2)
147 Q
148EXCLUDE ;This logic excludes services the user cannot send a consult to.
149 ;If GMRCTO=1 the user is forwarding or sending a consult
150 ;W=zeroth node of service,GMRCDG=ien of service,GMRCO=ien of consult (optional)
151 Q:'$L($G(W))
152 S GMRCEXCL=+$P(W,"^",2) ;Include grouper for hierarchy building only
153 I $G(GMRCTO),$G(GMRCO) D ;exclude fwd'ing into IFC svc
154 . I $P($G(^GMR(123,+GMRCO,12)),U,5)'="F" Q
155 . I +$G(^GMR(123.5,+GMRCDG,"IFC")) S GMRCEXCL=3 Q
156 . I $L($P($G(^GMR(123.5,+GMRCDG,"IFC")),U,2)) S GMRCEXCL=3 Q
157 I GMRCEXCL=2 D ;tracking service exclusion check
158 . N GMRCSRV I +$G(GMRCO) S GMRCSRV=$P($G(^GMR(123,+GMRCO,0)),"^",5) I $D(^GMR(123.5,"APC",+GMRCDG,+GMRCSRV)) S GMRCEXCL=0 Q ;Checks if parent is the consults current service
159 . I $$VALID^GMRCAU(+GMRCDG,,DUZ) S GMRCEXCL=0 ;update user?
160 . Q
161 Q
162CHECKDAD ;Check the service usage statuses for a selected services parents
163 ;There are two passes, one to get any user accessible parent
164 ;and the second pass is through the GMRCDAD array to check the parents usage
165 ;The GMRCEXCL value is returned for exclusion due to parent
166 S GMRCDAD=""
167 ;FIRST PASS
168 F S GMRCDAD=$O(^GMR(123.5,"APC",+GMRCDG,GMRCDAD)) Q:GMRCDAD="" D I $P($G(GMRCDAD(+GMRCDAD)),U,2)="OK" S GMRCEXCL="OK"
169 . S GMRCDAD(+GMRCDAD)=$P(^GMR(123.5,+GMRCDAD,0),U,2) ;dads service usage
170 . ;I $P($G(^GMR(123.5,+GMRCDAD,0)),U,1)="ALL SERVICES" S $P(GMRCDAD(GMRCDAD),U,2,3)="OK^ALL" Q ;If one of the dad's is all services, than OK to send to if not previously excluded.
171 . I GMRCDAD(+GMRCDAD)=1 S $P(GMRCDAD(+GMRCDAD),"^",2)="OK" Q ;Groupers Only are OK!
172 . I $$VALID^GMRCAU(+GMRCDAD,,DUZ) S $P(GMRCDAD(GMRCDAD),U,2,3)="OK^Update access" ;update user?
173 . Q
174 I GMRCEXCL="OK" S GMRCEXCL=0 Q ;There is a parent which user has access to.
175 ;Second Pass of the GMRCDAD array (multiple parents)
176 S GMRCDAD=$O(GMRCDAD("")) I 'GMRCDAD S GMRCEXCL=90 Q ;Not part of hierarchy; missing dad
177 ;Use first parent found in hierarchy.
178 S GMRCEXCL=+GMRCDAD(GMRCDAD)
179 Q
180READ ;;Hold screen
181 I $D(IOST) Q:$E(IOST)'="C"
182 W ! I $D(IOSL),$Y<(IOSL-4) G READ
183 N X W !?5,"Press RETURN to continue, ^ to exit: " R X:DTIME
184 S:X="^" DUOUT=1 S:'$T!(X="^^") DIROUT=1
185 I $D(DUOUT)!$D(DIROUT) S:$D(GMRCPRT) GMRCOUT=1
186 W @IOF
187 I '$D(DTOUT),('$D(DUOUT))&($D(GMRCPRT)) D PAGE^GMRCASV1(.GMRCPG)
188 Q
189 ;
190EXIT ;Kill off variables and quit
191 K DIROUT,DUOUT,DTOUT,DIRUT
192 Q
Note: See TracBrowser for help on using the repository browser.