- 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 Jan 18, 2025@02:46:23 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