GMRCASV ;SLC/KCM,DLT - Build ^TMP("GMRCS" of Svc(s)/Specialties ; 9/8/09 11:47am
;;3.0;CONSULT/REQUEST TRACKING;**1,12,18,22,53,71**;DEC 27, 1997;Build 14
; This routine invokes IA #2426
;
ASRV ;Ask for service/specialty group {output} GMRCDG,GMRCBUF,GMRCACT,^TMP("GMRCS",$J,^TMP("GMRCSLIST",$J
K GMRCQUT
N GMRCSEL
D SERV0 D:GMRCDG SERV1
K W,X,Y Q
SERV0 ;Assume that the lookup must begin with ALL SERVICES, or value of GMRCSVNM
;GMRCASV=the ask prompt text
;GMRCSVNM=text to use for default name
S GMRCDG=0
S:$G(GMRCASV)["Forward" GMRCTO=1
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
Q
ASKPRMPT ;Write the prompt and do the Read to get the user text entered in X
W !!,$S($D(GMRCASV):GMRCASV,1:"Select Service/Specialty: ")_$S($L($G(GMRCSVNM)):GMRCSVNM,1:"ALL SERVICES")_"// "
R X:DTIME
I '$T S X="^"
I X'["^" S X=$S($G(GMRCASV)["Forward"&('$L(X)):"^",'$L(X):"ALL SERVICES",1:X) Q
Q
SERV1 ;Create selected SERVICE ^TMP array of service information
;If GMRCTO=1 then the BILD section will not include disabled or tracking services which the user cannot send to.
N GMRCDGT
S GMRCBUF=GMRCDG
I GMRCBUF>0 D
. K ^TMP("GMRCS",$J),^TMP("GMRCSLIST",$J)
. S GMRCDGT=0,GMRCSEL="BILD" D EN
. S GMRCGRP("NAM")=^GMR(123.5,GMRCBUF,0)
. S (GMRCDG,GMRCGRP("ROOT"))=GMRCBUF
. S GMRCGRP("NAM")=$S($L($P(GMRCGRP("NAM"),"^",3)):$P(GMRCGRP("NAM"),"^",3),1:$E($P(GMRCGRP("NAM"),"^"),1,5))
K GMRCSEQ,GMRCBUF
Q
LKUP ;Ask the user for the service; use the value of x for lookup; branch to list on ??
; Patch 18 added Identifier to 123.5 in place of DIC("W")
; Remove commented line in next patch.
;S DIC="^GMR(123.5,",DIC(0)="MNEQZ"
;D ^DIC K DIC
; Patch 53 added screen to prevent Forwarding to a Tracking Service
I $G(GMRCTO)=1 S DIC("S")="I ($$VALID^GMRCAU(Y,DUZ)&($P($G(^GMR(123.5,Y,0)),U,2)=2))!($P($G(^GMR(123.5,Y,0)),U,2)="""")!($P($G(^GMR(123.5,Y,0)),U,2)=1)"
S DIC="^GMR(123.5,",DIC(0)="MNEQZ",D="B^D"
D MIX^DIC1 K DIC
I '$D(Y(0)) D LISTALL Q
N W,GMRCEXCL I +$G(GMRCTO) D
. S W=Y(0),GMRCDG=+Y
. S GMRCEXCL=0 D EXCLUDE
. I GMRCEXCL=1 S GMRCSVNM=Y(0,0),GMRCEXCL=0 Q
. K GMRCSVNM ;Service selected is not a grouper for lookup
. I GMRCEXCL=9 S GMRCMSG="You have selected a disabled service!" D EXAC^GMRCADC(GMRCMSG) K GMRCMSG Q
. 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
. N GMRCDAD D CHECKDAD
. 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
. ;I GMRCEXCL=9 S GMRCMSG="You have selected a service whose parent is disabled!" D EXAC^GMRCADC(GMRCMSG) K GMRCMSG Q
. 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
. 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
I +$G(GMRCEXCL) S Y=0,GMRCDG=0
S:Y>0 GMRCDG=+Y ;falls to here when service is a grouper or not excluded
Q
;
LISTOPT ;called from option to list hierarchy
S %ZIS="Q"
D ^%ZIS I POP Q
I $D(IO("Q")) D QUEUE^GMRCASV1 D ^%ZISC,HOME^%ZIS Q
D PRTLST
D ^%ZISC,HOME^%ZIS
Q
;
PRTLST ;queued entry point or just print it
I $D(ZTQUEUED) S ZTREQ="@"
U IO
N GMRCPRT,GMRCPG,GMRCTO,GMRCDG,GMRCOUT
N DUOUT,DTOUT,DIROUT
S GMRCPG=0,GMRCPRT=1
D PAGE^GMRCASV1(.GMRCPG)
D LISTALL I $D(GMRCOUT) Q
I $Y>(IOSL-4) D READ I $D(GMRCOUT) Q
W !!,"Services not currently part of the Consults Hierarchy:"
N SERV S SERV=1
F S SERV=$O(^GMR(123.5,SERV)) Q:'SERV Q:$D(GMRCOUT) D
. I '$D(^GMR(123.5,"APC",SERV)) D
.. I $Y>(IOSL-4) D READ I $D(GMRCOUT) Q
.. W !,?3,$P(^GMR(123.5,SERV,0),U) I '$P(^(0),U,2) Q
.. N USE S USE=$P(^GMR(123.5,SERV,0),U,2)
.. W " ("
.. W $S(USE=1:"Grouper Only",USE=9:"Disabled",1:"Tracking Only")_")"
K GMRCDG D EXIT
Q
LISTALL ;display LIST of Services in their hierarchy beginning with ALL SERVICES
S GMRCDG=$O(^GMR(123.5,"B","ALL SERVICES",0)) Q:'GMRCDG
S GMRCSEL="DISP" W:'$D(GMRCPRT) @IOF D EN
S GMRCDG=0 W !
Q
LISTSRV ;display LIST of sub-services beginning with a selected service
S GMRC1=0,GMRCDG=$O(^GMR(123.5,"B",GMRCSVNM,0)) Q:'GMRCDG
S GMRCSEL="DISP" W @IOF D EN
S GMRCDG=0 W !
Q
EN ;Setup Specialty groups entry: GMRCDG,GMRCSEL exit: GMRCGRP if GMRCSEL="BILD"
N GMRCSTK,PARENT,GMRCUSG,GMRCEXCL
S GMRCSTK=0,PARENT=0 ;beginning service logic
D @GMRCSEL Q:$D(DUOUT)!($D(DIROUT))!($D(GMRCOUT))
EN1 ;GMRCSTK is used to manage the level of stacks under beginning service
S GMRCSTK=1,GMRCSTK(GMRCSTK)=GMRCDG_"^0",GMRCSTK(0)=0,GMRCMEM=0,GMRCNAM=""
F S GMRCNAM=$O(^GMR(123.5,+GMRCSTK(GMRCSTK),10,"AC",GMRCNAM)) D D @$S(+GMRCMEM'>0:"POP",1:"PROC") Q:GMRCSTK<1
. I $G(GMRCEXCL) S GMRCMEM=0 Q ;Exclude children of excluded parent
. I '$L(GMRCNAM) S GMRCMEM=0 ;No more 10th node children
. E S GMRCMEM=$O(^GMR(123.5,+GMRCSTK(GMRCSTK),10,"AC",GMRCNAM,""))
K DUOUT,GMRCMEM,GMRCNAM,GMRCSTK,GMRCSEL
Q
POP ;Go back one level in service stack hierarchy and initialize exclude
S GMRCSTK=GMRCSTK-1,GMRCMEM=$P(GMRCSTK(GMRCSTK),"^",2),GMRCNAM=$P(GMRCSTK(GMRCSTK),"^",3),GMRCEXCL=0
Q
PROC ;GMRCMEM is the member ien in the 10th node being processed
;GMRCDG is the ien of file 123.5 being processed
;GMRCNAM is the services name
S $P(GMRCSTK(GMRCSTK),"^",2)=GMRCMEM
S $P(GMRCSTK(GMRCSTK),"^",3)=GMRCNAM
Q:'$D(^GMR(123.5,+GMRCSTK(GMRCSTK),10,GMRCMEM,0)) ;ghost "AC" x-ref
S GMRCDG=$P(^GMR(123.5,+GMRCSTK(GMRCSTK),10,GMRCMEM,0),"^",1)
S PARENT=+GMRCSTK(GMRCSTK)
S W=$G(^GMR(123.5,GMRCDG,0))
I $G(GMRCTO)=1 S GMRCEXCL=0 D EXCLUDE S:GMRCEXCL=1 GMRCEXCL=0 ;Includes grouper only
D:'+$G(GMRCEXCL) @GMRCSEL G:($D(DUOUT)!$D(DIROUT)) EXIT
;Initialize a stack level entry to process children of the multiple
S GMRCSTK=GMRCSTK+1,GMRCSTK(GMRCSTK)=GMRCDG_"^0",GMRCMEM=0,GMRCNAM=""
Q
DISP ;Display individual entries alphabetically for each service as processed
Q:$D(GMRCOUT)
I $Y>(IOSL-4) D READ S:$D(DUOUT)!($D(DIROUT)) GMRCSTK=0 G:GMRCSTK=0 EXIT
S W=$G(^GMR(123.5,GMRCDG,0))
S GMRCUSG=$P(W,"^",2)
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:"")
Q
BILD ;The following logic will build an array for review for GUI
;GMRCDGT=sequential number,GMRCDG=service pointer,
;W=^GMR(123.5,GMRCDG,0),1st piece is name, 2nd piece usage
;If GMRCTO=1 then services that only consults can be sent to will be
;included with the exception of "grouper only" which keeps the
;hierarchy in order.
N CHILD
S W=$G(^GMR(123.5,GMRCDG,0))
S ^TMP("GMRCS",$J,GMRCDG)=$P(W,"^")
S GMRCDGT=GMRCDGT+1
S CHILD=$O(^GMR(123.5,GMRCDG,10,0)) S CHILD=$S(+CHILD:"+",1:"")
S ^TMP("GMRCSLIST",$J,GMRCDGT)=GMRCDG_U_$P(W,"^")_U_PARENT_U_CHILD_U_$P(W,"^",2)
Q
EXCLUDE ;This logic excludes services the user cannot send a consult to.
;If GMRCTO=1 the user is forwarding or sending a consult
;W=zeroth node of service,GMRCDG=ien of service,GMRCO=ien of consult (optional)
Q:'$L($G(W))
S GMRCEXCL=+$P(W,"^",2) ;Include grouper for hierarchy building only
I $G(GMRCTO),$G(GMRCO) D ;exclude fwd'ing into IFC svc
. I $P($G(^GMR(123,+GMRCO,12)),U,5)'="F" Q
. I +$G(^GMR(123.5,+GMRCDG,"IFC")) S GMRCEXCL=3 Q
. I $L($P($G(^GMR(123.5,+GMRCDG,"IFC")),U,2)) S GMRCEXCL=3 Q
I GMRCEXCL=2 D ;tracking service exclusion check
. 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
. I $$VALID^GMRCAU(+GMRCDG,,DUZ) S GMRCEXCL=0 ;update user?
. Q
Q
CHECKDAD ;Check the service usage statuses for a selected services parents
;There are two passes, one to get any user accessible parent
;and the second pass is through the GMRCDAD array to check the parents usage
;The GMRCEXCL value is returned for exclusion due to parent
S GMRCDAD=""
;FIRST PASS
F S GMRCDAD=$O(^GMR(123.5,"APC",+GMRCDG,GMRCDAD)) Q:GMRCDAD="" D I $P($G(GMRCDAD(+GMRCDAD)),U,2)="OK" S GMRCEXCL="OK"
. S GMRCDAD(+GMRCDAD)=$P(^GMR(123.5,+GMRCDAD,0),U,2) ;dads service usage
. ;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.
. I GMRCDAD(+GMRCDAD)=1 S $P(GMRCDAD(+GMRCDAD),"^",2)="OK" Q ;Groupers Only are OK!
. I $$VALID^GMRCAU(+GMRCDAD,,DUZ) S $P(GMRCDAD(GMRCDAD),U,2,3)="OK^Update access" ;update user?
. Q
I GMRCEXCL="OK" S GMRCEXCL=0 Q ;There is a parent which user has access to.
;Second Pass of the GMRCDAD array (multiple parents)
S GMRCDAD=$O(GMRCDAD("")) I 'GMRCDAD S GMRCEXCL=90 Q ;Not part of hierarchy; missing dad
;Use first parent found in hierarchy.
S GMRCEXCL=+GMRCDAD(GMRCDAD)
Q
READ ;;Hold screen
I $D(IOST) Q:$E(IOST)'="C"
W ! I $D(IOSL),$Y<(IOSL-4) G READ
N X W !?5,"Press RETURN to continue, ^ to exit: " R X:DTIME
S:X="^" DUOUT=1 S:'$T!(X="^^") DIROUT=1
I $D(DUOUT)!$D(DIROUT) S:$D(GMRCPRT) GMRCOUT=1
W @IOF
I '$D(DTOUT),('$D(DUOUT))&($D(GMRCPRT)) D PAGE^GMRCASV1(.GMRCPG)
Q
;
EXIT ;Kill off variables and quit
K DIROUT,DUOUT,DTOUT,DIRUT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCASV 9674 printed Apr 09, 2024@20:52:43 Page 2
GMRCASV ;SLC/KCM,DLT - Build ^TMP("GMRCS" of Svc(s)/Specialties ; 9/8/09 11:47am
+1 ;;3.0;CONSULT/REQUEST TRACKING;**1,12,18,22,53,71**;DEC 27, 1997;Build 14
+2 ; This routine invokes IA #2426
+3 ;
ASRV ;Ask for service/specialty group {output} GMRCDG,GMRCBUF,GMRCACT,^TMP("GMRCS",$J,^TMP("GMRCSLIST",$J
+1 KILL GMRCQUT
+2 NEW GMRCSEL
+3 DO SERV0
if GMRCDG
DO SERV1
+4 KILL W,X,Y
QUIT
SERV0 ;Assume that the lookup must begin with ALL SERVICES, or value of GMRCSVNM
+1 ;GMRCASV=the ask prompt text
+2 ;GMRCSVNM=text to use for default name
+3 SET GMRCDG=0
+4 if $GET(GMRCASV)["Forward"
SET GMRCTO=1
+5 FOR
DO ASKPRMPT
if X["^^"
SET DIROUT=1
if X["^"
SET GMRCQUT=1
if X["^"
QUIT
DO @$SELECT(X["?":"LISTALL",1:"LKUP")
if ($LENGTH($GET(GMRCSVNM))&GMRCDG)
DO LISTSRV
if GMRCDG
QUIT
+6 QUIT
ASKPRMPT ;Write the prompt and do the Read to get the user text entered in X
+1 WRITE !!,$SELECT($DATA(GMRCASV):GMRCASV,1:"Select Service/Specialty: ")_$SELECT($LENGTH($GET(GMRCSVNM)):GMRCSVNM,1:"ALL SERVICES")_"// "
+2 READ X:DTIME
+3 IF '$TEST
SET X="^"
+4 IF X'["^"
SET X=$SELECT($GET(GMRCASV)["Forward"&('$LENGTH(X)):"^",'$LENGTH(X):"ALL SERVICES",1:X)
QUIT
+5 QUIT
SERV1 ;Create selected SERVICE ^TMP array of service information
+1 ;If GMRCTO=1 then the BILD section will not include disabled or tracking services which the user cannot send to.
+2 NEW GMRCDGT
+3 SET GMRCBUF=GMRCDG
+4 IF GMRCBUF>0
Begin DoDot:1
+5 KILL ^TMP("GMRCS",$JOB),^TMP("GMRCSLIST",$JOB)
+6 SET GMRCDGT=0
SET GMRCSEL="BILD"
DO EN
+7 SET GMRCGRP("NAM")=^GMR(123.5,GMRCBUF,0)
+8 SET (GMRCDG,GMRCGRP("ROOT"))=GMRCBUF
+9 SET GMRCGRP("NAM")=$SELECT($LENGTH($PIECE(GMRCGRP("NAM"),"^",3)):$PIECE(GMRCGRP("NAM"),"^",3),1:$EXTRACT($PIECE(GMRCGRP("NAM"),"^"),1,5))
End DoDot:1
+10 KILL GMRCSEQ,GMRCBUF
+11 QUIT
LKUP ;Ask the user for the service; use the value of x for lookup; branch to list on ??
+1 ; Patch 18 added Identifier to 123.5 in place of DIC("W")
+2 ; Remove commented line in next patch.
+3 ;S DIC="^GMR(123.5,",DIC(0)="MNEQZ"
+4 ;D ^DIC K DIC
+5 ; Patch 53 added screen to prevent Forwarding to a Tracking Service
+6 IF $GET(GMRCTO)=1
SET DIC("S")="I ($$VALID^GMRCAU(Y,DUZ)&($P($G(^GMR(123.5,Y,0)),U,2)=2))!($P($G(^GMR(123.5,Y,0)),U,2)="""")!($P($G(^GMR(123.5,Y,0)),U,2)=1)"
+7 SET DIC="^GMR(123.5,"
SET DIC(0)="MNEQZ"
SET D="B^D"
+8 DO MIX^DIC1
KILL DIC
+9 IF '$DATA(Y(0))
DO LISTALL
QUIT
+10 NEW W,GMRCEXCL
IF +$GET(GMRCTO)
Begin DoDot:1
+11 SET W=Y(0)
SET GMRCDG=+Y
+12 SET GMRCEXCL=0
DO EXCLUDE
+13 IF GMRCEXCL=1
SET GMRCSVNM=Y(0,0)
SET GMRCEXCL=0
QUIT
+14 ;Service selected is not a grouper for lookup
KILL GMRCSVNM
+15 IF GMRCEXCL=9
SET GMRCMSG="You have selected a disabled service!"
DO EXAC^GMRCADC(GMRCMSG)
KILL GMRCMSG
QUIT
+16 IF GMRCEXCL=3
SET GMRCMSG="You may not forward this Inter-facility Consult to another inter-facility consult service."
DO EXAC^GMRCADC(GMRCMSG)
KILL GMRCMSG
QUIT
+17 NEW GMRCDAD
DO CHECKDAD
+18 IF GMRCEXCL=90
SET GMRCMSG="You have selected a service that is not part of the ALL SERVICES hierarchy!"
SET GMRCMSG(1)="Contact Consult ADPAC"
DO EXAC^GMRCADC(.GMRCMSG)
KILL GMRCMSG
QUIT
+19 ;I GMRCEXCL=9 S GMRCMSG="You have selected a service whose parent is disabled!" D EXAC^GMRCADC(GMRCMSG) K GMRCMSG Q
+20 IF GMRCEXCL=2
SET GMRCMSG="You have selected a service whose parent is a tracking service!"
SET GMRCMSG(1)="You do not have authorization to send consults to this service."
DO EXAC^GMRCADC(.GMRCMSG)
KILL GMRCMSG
QUIT
+21 IF GMRCEXCL=3
SET GMRCMSG="You may not forward this Inter-facility Consult to another inter-facility consult service."
DO EXAC^GMRCADC(GMRCMSG)
KILL GMRCMSG
QUIT
End DoDot:1
+22 IF +$GET(GMRCEXCL)
SET Y=0
SET GMRCDG=0
+23 ;falls to here when service is a grouper or not excluded
if Y>0
SET GMRCDG=+Y
+24 QUIT
+25 ;
LISTOPT ;called from option to list hierarchy
+1 SET %ZIS="Q"
+2 DO ^%ZIS
IF POP
QUIT
+3 IF $DATA(IO("Q"))
DO QUEUE^GMRCASV1
DO ^%ZISC
DO HOME^%ZIS
QUIT
+4 DO PRTLST
+5 DO ^%ZISC
DO HOME^%ZIS
+6 QUIT
+7 ;
PRTLST ;queued entry point or just print it
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 USE IO
+3 NEW GMRCPRT,GMRCPG,GMRCTO,GMRCDG,GMRCOUT
+4 NEW DUOUT,DTOUT,DIROUT
+5 SET GMRCPG=0
SET GMRCPRT=1
+6 DO PAGE^GMRCASV1(.GMRCPG)
+7 DO LISTALL
IF $DATA(GMRCOUT)
QUIT
+8 IF $Y>(IOSL-4)
DO READ
IF $DATA(GMRCOUT)
QUIT
+9 WRITE !!,"Services not currently part of the Consults Hierarchy:"
+10 NEW SERV
SET SERV=1
+11 FOR
SET SERV=$ORDER(^GMR(123.5,SERV))
if 'SERV
QUIT
if $DATA(GMRCOUT)
QUIT
Begin DoDot:1
+12 IF '$DATA(^GMR(123.5,"APC",SERV))
Begin DoDot:2
+13 IF $Y>(IOSL-4)
DO READ
IF $DATA(GMRCOUT)
QUIT
+14 WRITE !,?3,$PIECE(^GMR(123.5,SERV,0),U)
IF '$PIECE(^(0),U,2)
QUIT
+15 NEW USE
SET USE=$PIECE(^GMR(123.5,SERV,0),U,2)
+16 WRITE " ("
+17 WRITE $SELECT(USE=1:"Grouper Only",USE=9:"Disabled",1:"Tracking Only")_")"
End DoDot:2
End DoDot:1
+18 KILL GMRCDG
DO EXIT
+19 QUIT
LISTALL ;display LIST of Services in their hierarchy beginning with ALL SERVICES
+1 SET GMRCDG=$ORDER(^GMR(123.5,"B","ALL SERVICES",0))
if 'GMRCDG
QUIT
+2 SET GMRCSEL="DISP"
if '$DATA(GMRCPRT)
WRITE @IOF
DO EN
+3 SET GMRCDG=0
WRITE !
+4 QUIT
LISTSRV ;display LIST of sub-services beginning with a selected service
+1 SET GMRC1=0
SET GMRCDG=$ORDER(^GMR(123.5,"B",GMRCSVNM,0))
if 'GMRCDG
QUIT
+2 SET GMRCSEL="DISP"
WRITE @IOF
DO EN
+3 SET GMRCDG=0
WRITE !
+4 QUIT
EN ;Setup Specialty groups entry: GMRCDG,GMRCSEL exit: GMRCGRP if GMRCSEL="BILD"
+1 NEW GMRCSTK,PARENT,GMRCUSG,GMRCEXCL
+2 ;beginning service logic
SET GMRCSTK=0
SET PARENT=0
+3 DO @GMRCSEL
if $DATA(DUOUT)!($DATA(DIROUT))!($DATA(GMRCOUT))
QUIT
EN1 ;GMRCSTK is used to manage the level of stacks under beginning service
+1 SET GMRCSTK=1
SET GMRCSTK(GMRCSTK)=GMRCDG_"^0"
SET GMRCSTK(0)=0
SET GMRCMEM=0
SET GMRCNAM=""
+2 FOR
SET GMRCNAM=$ORDER(^GMR(123.5,+GMRCSTK(GMRCSTK),10,"AC",GMRCNAM))
Begin DoDot:1
+3 ;Exclude children of excluded parent
IF $GET(GMRCEXCL)
SET GMRCMEM=0
QUIT
+4 ;No more 10th node children
IF '$LENGTH(GMRCNAM)
SET GMRCMEM=0
+5 IF '$TEST
SET GMRCMEM=$ORDER(^GMR(123.5,+GMRCSTK(GMRCSTK),10,"AC",GMRCNAM,""))
End DoDot:1
DO @$SELECT(+GMRCMEM'>0:"POP",1:"PROC")
if GMRCSTK<1
QUIT
+6 KILL DUOUT,GMRCMEM,GMRCNAM,GMRCSTK,GMRCSEL
+7 QUIT
POP ;Go back one level in service stack hierarchy and initialize exclude
+1 SET GMRCSTK=GMRCSTK-1
SET GMRCMEM=$PIECE(GMRCSTK(GMRCSTK),"^",2)
SET GMRCNAM=$PIECE(GMRCSTK(GMRCSTK),"^",3)
SET GMRCEXCL=0
+2 QUIT
PROC ;GMRCMEM is the member ien in the 10th node being processed
+1 ;GMRCDG is the ien of file 123.5 being processed
+2 ;GMRCNAM is the services name
+3 SET $PIECE(GMRCSTK(GMRCSTK),"^",2)=GMRCMEM
+4 SET $PIECE(GMRCSTK(GMRCSTK),"^",3)=GMRCNAM
+5 ;ghost "AC" x-ref
if '$DATA(^GMR(123.5,+GMRCSTK(GMRCSTK),10,GMRCMEM,0))
QUIT
+6 SET GMRCDG=$PIECE(^GMR(123.5,+GMRCSTK(GMRCSTK),10,GMRCMEM,0),"^",1)
+7 SET PARENT=+GMRCSTK(GMRCSTK)
+8 SET W=$GET(^GMR(123.5,GMRCDG,0))
+9 ;Includes grouper only
IF $GET(GMRCTO)=1
SET GMRCEXCL=0
DO EXCLUDE
if GMRCEXCL=1
SET GMRCEXCL=0
+10 if '+$GET(GMRCEXCL)
DO @GMRCSEL
if ($DATA(DUOUT)!$DATA(DIROUT))
GOTO EXIT
+11 ;Initialize a stack level entry to process children of the multiple
+12 SET GMRCSTK=GMRCSTK+1
SET GMRCSTK(GMRCSTK)=GMRCDG_"^0"
SET GMRCMEM=0
SET GMRCNAM=""
+13 QUIT
DISP ;Display individual entries alphabetically for each service as processed
+1 if $DATA(GMRCOUT)
QUIT
+2 IF $Y>(IOSL-4)
DO READ
if $DATA(DUOUT)!($DATA(DIROUT))
SET GMRCSTK=0
if GMRCSTK=0
GOTO EXIT
+3 SET W=$GET(^GMR(123.5,GMRCDG,0))
+4 SET GMRCUSG=$PIECE(W,"^",2)
+5 WRITE !,?((GMRCSTK*2)),$SELECT(GMRCUSG=9:"<",1:"")_$PIECE(W,"^")_$SELECT(GMRCUSG=9:">",1:"")_" "_$SELECT(GMRCUSG=1:"(Grouper Only)",GMRCUSG=2:"(Tracking Only)",GMRCUSG=9:"<Disabled>",1:"")_" "_$SELECT(...
... $GET(^GMR(123.5,GMRCDG,"IFC")):"(Inter-facility)",1:"")
+6 QUIT
BILD ;The following logic will build an array for review for GUI
+1 ;GMRCDGT=sequential number,GMRCDG=service pointer,
+2 ;W=^GMR(123.5,GMRCDG,0),1st piece is name, 2nd piece usage
+3 ;If GMRCTO=1 then services that only consults can be sent to will be
+4 ;included with the exception of "grouper only" which keeps the
+5 ;hierarchy in order.
+6 NEW CHILD
+7 SET W=$GET(^GMR(123.5,GMRCDG,0))
+8 SET ^TMP("GMRCS",$JOB,GMRCDG)=$PIECE(W,"^")
+9 SET GMRCDGT=GMRCDGT+1
+10 SET CHILD=$ORDER(^GMR(123.5,GMRCDG,10,0))
SET CHILD=$SELECT(+CHILD:"+",1:"")
+11 SET ^TMP("GMRCSLIST",$JOB,GMRCDGT)=GMRCDG_U_$PIECE(W,"^")_U_PARENT_U_CHILD_U_$PIECE(W,"^",2)
+12 QUIT
EXCLUDE ;This logic excludes services the user cannot send a consult to.
+1 ;If GMRCTO=1 the user is forwarding or sending a consult
+2 ;W=zeroth node of service,GMRCDG=ien of service,GMRCO=ien of consult (optional)
+3 if '$LENGTH($GET(W))
QUIT
+4 ;Include grouper for hierarchy building only
SET GMRCEXCL=+$PIECE(W,"^",2)
+5 ;exclude fwd'ing into IFC svc
IF $GET(GMRCTO)
IF $GET(GMRCO)
Begin DoDot:1
+6 IF $PIECE($GET(^GMR(123,+GMRCO,12)),U,5)'="F"
QUIT
+7 IF +$GET(^GMR(123.5,+GMRCDG,"IFC"))
SET GMRCEXCL=3
QUIT
+8 IF $LENGTH($PIECE($GET(^GMR(123.5,+GMRCDG,"IFC")),U,2))
SET GMRCEXCL=3
QUIT
End DoDot:1
+9 ;tracking service exclusion check
IF GMRCEXCL=2
Begin DoDot:1
+10 ;Checks if parent is the consults current service
NEW GMRCSRV
IF +$GET(GMRCO)
SET GMRCSRV=$PIECE($GET(^GMR(123,+GMRCO,0)),"^",5)
IF $DATA(^GMR(123.5,"APC",+GMRCDG,+GMRCSRV))
SET GMRCEXCL=0
QUIT
+11 ;update user?
IF $$VALID^GMRCAU(+GMRCDG,,DUZ)
SET GMRCEXCL=0
+12 QUIT
End DoDot:1
+13 QUIT
CHECKDAD ;Check the service usage statuses for a selected services parents
+1 ;There are two passes, one to get any user accessible parent
+2 ;and the second pass is through the GMRCDAD array to check the parents usage
+3 ;The GMRCEXCL value is returned for exclusion due to parent
+4 SET GMRCDAD=""
+5 ;FIRST PASS
+6 FOR
SET GMRCDAD=$ORDER(^GMR(123.5,"APC",+GMRCDG,GMRCDAD))
if GMRCDAD=""
QUIT
Begin DoDot:1
+7 ;dads service usage
SET GMRCDAD(+GMRCDAD)=$PIECE(^GMR(123.5,+GMRCDAD,0),U,2)
+8 ;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.
+9 ;Groupers Only are OK!
IF GMRCDAD(+GMRCDAD)=1
SET $PIECE(GMRCDAD(+GMRCDAD),"^",2)="OK"
QUIT
+10 ;update user?
IF $$VALID^GMRCAU(+GMRCDAD,,DUZ)
SET $PIECE(GMRCDAD(GMRCDAD),U,2,3)="OK^Update access"
+11 QUIT
End DoDot:1
IF $PIECE($GET(GMRCDAD(+GMRCDAD)),U,2)="OK"
SET GMRCEXCL="OK"
+12 ;There is a parent which user has access to.
IF GMRCEXCL="OK"
SET GMRCEXCL=0
QUIT
+13 ;Second Pass of the GMRCDAD array (multiple parents)
+14 ;Not part of hierarchy; missing dad
SET GMRCDAD=$ORDER(GMRCDAD(""))
IF 'GMRCDAD
SET GMRCEXCL=90
QUIT
+15 ;Use first parent found in hierarchy.
+16 SET GMRCEXCL=+GMRCDAD(GMRCDAD)
+17 QUIT
READ ;;Hold screen
+1 IF $DATA(IOST)
if $EXTRACT(IOST)'="C"
QUIT
+2 WRITE !
IF $DATA(IOSL)
IF $Y<(IOSL-4)
GOTO READ
+3 NEW X
WRITE !?5,"Press RETURN to continue, ^ to exit: "
READ X:DTIME
+4 if X="^"
SET DUOUT=1
if '$TEST!(X="^^")
SET DIROUT=1
+5 IF $DATA(DUOUT)!$DATA(DIROUT)
if $DATA(GMRCPRT)
SET GMRCOUT=1
+6 WRITE @IOF
+7 IF '$DATA(DTOUT)
IF ('$DATA(DUOUT))&($DATA(GMRCPRT))
DO PAGE^GMRCASV1(.GMRCPG)
+8 QUIT
+9 ;
EXIT ;Kill off variables and quit
+1 KILL DIROUT,DUOUT,DTOUT,DIRUT
+2 QUIT
