Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: GMRCASV

GMRCASV.m

Go to the documentation of this file.
  1. 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
  1. ; This routine invokes IA #2426
  1. ;
  1. ASRV ;Ask for service/specialty group {output} GMRCDG,GMRCBUF,GMRCACT,^TMP("GMRCS",$J,^TMP("GMRCSLIST",$J
  1. K GMRCQUT
  1. N GMRCSEL
  1. D SERV0 D:GMRCDG SERV1
  1. K W,X,Y Q
  1. SERV0 ;Assume that the lookup must begin with ALL SERVICES, or value of GMRCSVNM
  1. ;GMRCASV=the ask prompt text
  1. ;GMRCSVNM=text to use for default name
  1. S GMRCDG=0
  1. S:$G(GMRCASV)["Forward" GMRCTO=1
  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
  1. Q
  1. ASKPRMPT ;Write the prompt and do the Read to get the user text entered in X
  1. W !!,$S($D(GMRCASV):GMRCASV,1:"Select Service/Specialty: ")_$S($L($G(GMRCSVNM)):GMRCSVNM,1:"ALL SERVICES")_"// "
  1. R X:DTIME
  1. I '$T S X="^"
  1. I X'["^" S X=$S($G(GMRCASV)["Forward"&('$L(X)):"^",'$L(X):"ALL SERVICES",1:X) Q
  1. Q
  1. 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.
  1. N GMRCDGT
  1. S GMRCBUF=GMRCDG
  1. I GMRCBUF>0 D
  1. . K ^TMP("GMRCS",$J),^TMP("GMRCSLIST",$J)
  1. . S GMRCDGT=0,GMRCSEL="BILD" D EN
  1. . S GMRCGRP("NAM")=^GMR(123.5,GMRCBUF,0)
  1. . S (GMRCDG,GMRCGRP("ROOT"))=GMRCBUF
  1. . S GMRCGRP("NAM")=$S($L($P(GMRCGRP("NAM"),"^",3)):$P(GMRCGRP("NAM"),"^",3),1:$E($P(GMRCGRP("NAM"),"^"),1,5))
  1. K GMRCSEQ,GMRCBUF
  1. Q
  1. 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")
  1. ; Remove commented line in next patch.
  1. ;S DIC="^GMR(123.5,",DIC(0)="MNEQZ"
  1. ;D ^DIC K DIC
  1. ; Patch 53 added screen to prevent Forwarding to a Tracking Service
  1. 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)"
  1. S DIC="^GMR(123.5,",DIC(0)="MNEQZ",D="B^D"
  1. D MIX^DIC1 K DIC
  1. I '$D(Y(0)) D LISTALL Q
  1. N W,GMRCEXCL I +$G(GMRCTO) D
  1. . S W=Y(0),GMRCDG=+Y
  1. . S GMRCEXCL=0 D EXCLUDE
  1. . I GMRCEXCL=1 S GMRCSVNM=Y(0,0),GMRCEXCL=0 Q
  1. . K GMRCSVNM ;Service selected is not a grouper for lookup
  1. . I GMRCEXCL=9 S GMRCMSG="You have selected a disabled service!" D EXAC^GMRCADC(GMRCMSG) K GMRCMSG Q
  1. . 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
  1. . N GMRCDAD D CHECKDAD
  1. . 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
  1. . ;I GMRCEXCL=9 S GMRCMSG="You have selected a service whose parent is disabled!" D EXAC^GMRCADC(GMRCMSG) K GMRCMSG Q
  1. . 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
  1. . 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
  1. I +$G(GMRCEXCL) S Y=0,GMRCDG=0
  1. S:Y>0 GMRCDG=+Y ;falls to here when service is a grouper or not excluded
  1. Q
  1. ;
  1. LISTOPT ;called from option to list hierarchy
  1. S %ZIS="Q"
  1. D ^%ZIS I POP Q
  1. I $D(IO("Q")) D QUEUE^GMRCASV1 D ^%ZISC,HOME^%ZIS Q
  1. D PRTLST
  1. D ^%ZISC,HOME^%ZIS
  1. Q
  1. ;
  1. PRTLST ;queued entry point or just print it
  1. I $D(ZTQUEUED) S ZTREQ="@"
  1. U IO
  1. N GMRCPRT,GMRCPG,GMRCTO,GMRCDG,GMRCOUT
  1. N DUOUT,DTOUT,DIROUT
  1. S GMRCPG=0,GMRCPRT=1
  1. D PAGE^GMRCASV1(.GMRCPG)
  1. D LISTALL I $D(GMRCOUT) Q
  1. I $Y>(IOSL-4) D READ I $D(GMRCOUT) Q
  1. W !!,"Services not currently part of the Consults Hierarchy:"
  1. N SERV S SERV=1
  1. F S SERV=$O(^GMR(123.5,SERV)) Q:'SERV Q:$D(GMRCOUT) D
  1. . I '$D(^GMR(123.5,"APC",SERV)) D
  1. .. I $Y>(IOSL-4) D READ I $D(GMRCOUT) Q
  1. .. W !,?3,$P(^GMR(123.5,SERV,0),U) I '$P(^(0),U,2) Q
  1. .. N USE S USE=$P(^GMR(123.5,SERV,0),U,2)
  1. .. W " ("
  1. .. W $S(USE=1:"Grouper Only",USE=9:"Disabled",1:"Tracking Only")_")"
  1. K GMRCDG D EXIT
  1. Q
  1. LISTALL ;display LIST of Services in their hierarchy beginning with ALL SERVICES
  1. S GMRCDG=$O(^GMR(123.5,"B","ALL SERVICES",0)) Q:'GMRCDG
  1. S GMRCSEL="DISP" W:'$D(GMRCPRT) @IOF D EN
  1. S GMRCDG=0 W !
  1. Q
  1. LISTSRV ;display LIST of sub-services beginning with a selected service
  1. S GMRC1=0,GMRCDG=$O(^GMR(123.5,"B",GMRCSVNM,0)) Q:'GMRCDG
  1. S GMRCSEL="DISP" W @IOF D EN
  1. S GMRCDG=0 W !
  1. Q
  1. EN ;Setup Specialty groups entry: GMRCDG,GMRCSEL exit: GMRCGRP if GMRCSEL="BILD"
  1. N GMRCSTK,PARENT,GMRCUSG,GMRCEXCL
  1. S GMRCSTK=0,PARENT=0 ;beginning service logic
  1. D @GMRCSEL Q:$D(DUOUT)!($D(DIROUT))!($D(GMRCOUT))
  1. EN1 ;GMRCSTK is used to manage the level of stacks under beginning service
  1. S GMRCSTK=1,GMRCSTK(GMRCSTK)=GMRCDG_"^0",GMRCSTK(0)=0,GMRCMEM=0,GMRCNAM=""
  1. F S GMRCNAM=$O(^GMR(123.5,+GMRCSTK(GMRCSTK),10,"AC",GMRCNAM)) D D @$S(+GMRCMEM'>0:"POP",1:"PROC") Q:GMRCSTK<1
  1. . I $G(GMRCEXCL) S GMRCMEM=0 Q ;Exclude children of excluded parent
  1. . I '$L(GMRCNAM) S GMRCMEM=0 ;No more 10th node children
  1. . E S GMRCMEM=$O(^GMR(123.5,+GMRCSTK(GMRCSTK),10,"AC",GMRCNAM,""))
  1. K DUOUT,GMRCMEM,GMRCNAM,GMRCSTK,GMRCSEL
  1. Q
  1. POP ;Go back one level in service stack hierarchy and initialize exclude
  1. S GMRCSTK=GMRCSTK-1,GMRCMEM=$P(GMRCSTK(GMRCSTK),"^",2),GMRCNAM=$P(GMRCSTK(GMRCSTK),"^",3),GMRCEXCL=0
  1. Q
  1. PROC ;GMRCMEM is the member ien in the 10th node being processed
  1. ;GMRCDG is the ien of file 123.5 being processed
  1. ;GMRCNAM is the services name
  1. S $P(GMRCSTK(GMRCSTK),"^",2)=GMRCMEM
  1. S $P(GMRCSTK(GMRCSTK),"^",3)=GMRCNAM
  1. Q:'$D(^GMR(123.5,+GMRCSTK(GMRCSTK),10,GMRCMEM,0)) ;ghost "AC" x-ref
  1. S GMRCDG=$P(^GMR(123.5,+GMRCSTK(GMRCSTK),10,GMRCMEM,0),"^",1)
  1. S PARENT=+GMRCSTK(GMRCSTK)
  1. S W=$G(^GMR(123.5,GMRCDG,0))
  1. I $G(GMRCTO)=1 S GMRCEXCL=0 D EXCLUDE S:GMRCEXCL=1 GMRCEXCL=0 ;Includes grouper only
  1. D:'+$G(GMRCEXCL) @GMRCSEL G:($D(DUOUT)!$D(DIROUT)) EXIT
  1. ;Initialize a stack level entry to process children of the multiple
  1. S GMRCSTK=GMRCSTK+1,GMRCSTK(GMRCSTK)=GMRCDG_"^0",GMRCMEM=0,GMRCNAM=""
  1. Q
  1. DISP ;Display individual entries alphabetically for each service as processed
  1. Q:$D(GMRCOUT)
  1. I $Y>(IOSL-4) D READ S:$D(DUOUT)!($D(DIROUT)) GMRCSTK=0 G:GMRCSTK=0 EXIT
  1. S W=$G(^GMR(123.5,GMRCDG,0))
  1. S GMRCUSG=$P(W,"^",2)
  1. 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:"")
  1. Q
  1. BILD ;The following logic will build an array for review for GUI
  1. ;GMRCDGT=sequential number,GMRCDG=service pointer,
  1. ;W=^GMR(123.5,GMRCDG,0),1st piece is name, 2nd piece usage
  1. ;If GMRCTO=1 then services that only consults can be sent to will be
  1. ;included with the exception of "grouper only" which keeps the
  1. ;hierarchy in order.
  1. N CHILD
  1. S W=$G(^GMR(123.5,GMRCDG,0))
  1. S ^TMP("GMRCS",$J,GMRCDG)=$P(W,"^")
  1. S GMRCDGT=GMRCDGT+1
  1. S CHILD=$O(^GMR(123.5,GMRCDG,10,0)) S CHILD=$S(+CHILD:"+",1:"")
  1. S ^TMP("GMRCSLIST",$J,GMRCDGT)=GMRCDG_U_$P(W,"^")_U_PARENT_U_CHILD_U_$P(W,"^",2)
  1. Q
  1. EXCLUDE ;This logic excludes services the user cannot send a consult to.
  1. ;If GMRCTO=1 the user is forwarding or sending a consult
  1. ;W=zeroth node of service,GMRCDG=ien of service,GMRCO=ien of consult (optional)
  1. Q:'$L($G(W))
  1. S GMRCEXCL=+$P(W,"^",2) ;Include grouper for hierarchy building only
  1. I $G(GMRCTO),$G(GMRCO) D ;exclude fwd'ing into IFC svc
  1. . I $P($G(^GMR(123,+GMRCO,12)),U,5)'="F" Q
  1. . I +$G(^GMR(123.5,+GMRCDG,"IFC")) S GMRCEXCL=3 Q
  1. . I $L($P($G(^GMR(123.5,+GMRCDG,"IFC")),U,2)) S GMRCEXCL=3 Q
  1. I GMRCEXCL=2 D ;tracking service exclusion check
  1. . 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
  1. . I $$VALID^GMRCAU(+GMRCDG,,DUZ) S GMRCEXCL=0 ;update user?
  1. . Q
  1. Q
  1. CHECKDAD ;Check the service usage statuses for a selected services parents
  1. ;There are two passes, one to get any user accessible parent
  1. ;and the second pass is through the GMRCDAD array to check the parents usage
  1. ;The GMRCEXCL value is returned for exclusion due to parent
  1. S GMRCDAD=""
  1. ;FIRST PASS
  1. F S GMRCDAD=$O(^GMR(123.5,"APC",+GMRCDG,GMRCDAD)) Q:GMRCDAD="" D I $P($G(GMRCDAD(+GMRCDAD)),U,2)="OK" S GMRCEXCL="OK"
  1. . S GMRCDAD(+GMRCDAD)=$P(^GMR(123.5,+GMRCDAD,0),U,2) ;dads service usage
  1. . ;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.
  1. . I GMRCDAD(+GMRCDAD)=1 S $P(GMRCDAD(+GMRCDAD),"^",2)="OK" Q ;Groupers Only are OK!
  1. . I $$VALID^GMRCAU(+GMRCDAD,,DUZ) S $P(GMRCDAD(GMRCDAD),U,2,3)="OK^Update access" ;update user?
  1. . Q
  1. I GMRCEXCL="OK" S GMRCEXCL=0 Q ;There is a parent which user has access to.
  1. ;Second Pass of the GMRCDAD array (multiple parents)
  1. S GMRCDAD=$O(GMRCDAD("")) I 'GMRCDAD S GMRCEXCL=90 Q ;Not part of hierarchy; missing dad
  1. ;Use first parent found in hierarchy.
  1. S GMRCEXCL=+GMRCDAD(GMRCDAD)
  1. Q
  1. READ ;;Hold screen
  1. I $D(IOST) Q:$E(IOST)'="C"
  1. W ! I $D(IOSL),$Y<(IOSL-4) G READ
  1. N X W !?5,"Press RETURN to continue, ^ to exit: " R X:DTIME
  1. S:X="^" DUOUT=1 S:'$T!(X="^^") DIROUT=1
  1. I $D(DUOUT)!$D(DIROUT) S:$D(GMRCPRT) GMRCOUT=1
  1. W @IOF
  1. I '$D(DTOUT),('$D(DUOUT))&($D(GMRCPRT)) D PAGE^GMRCASV1(.GMRCPG)
  1. Q
  1. ;
  1. EXIT ;Kill off variables and quit
  1. K DIROUT,DUOUT,DTOUT,DIRUT
  1. Q