- GMRCPS ;SLC/KCM,DLT -Select Service/specialty to send Consult to ;5/20/98 14:20
- ;;3.0;CONSULT/REQUEST TRACKING;**1**;DEC 27, 1997
- ASRV W ! D SERV D:GMRCDG SERV1
- Q
- SERV ;Select from Hierarchy of services defined in 123.5
- K X N GMRC1 S GMRCSTXT="Service/Specialty",GMRCSTXT(0)="ALL SERVICES",GMRCDG=0,GMRC1=0
- F W !,"Select 'TO' Service/Specialty: " R X:DTIME S:'$L(X)&(GMRC1=0) X="^" S:X["^^" DIROUT=1 Q:X["^" S:GMRC1=1&('$L(X)) X="?" S:GMRC1=1 GMRC1=0 D @$S(X["?":"LSRV",1:"LKUP") I GMRCDG S GMRCDGT=GMRCDG Q
- I 'GMRCDG S GMRCACT("D")="Redisplay Screen"
- K GMRCSTXT,DUOUT,DIROUT Q
- SERV1 ;
- S GMRCBUF=GMRCDG
- I GMRCBUF>0 K GMRCGRP S GMRCSEL="BILD" D EN^GMRCASV S GMRCGRP("NAM")=^GMR(123.5,GMRCBUF,0),GMRCGRP("ROOT")=GMRCBUF,GMRCGRP("NAM")=$S($L($P(GMRCGRP("NAM"),"^",3)):$P(GMRCGRP("NAM"),"^",3),1:$E($P(GMRCGRP("NAM"),"^"),1,5))
- I $P(^GMR(123.5,GMRCBUF,0),"^",1)'="ALL SERVICES"
- K GMRCDG,GMRCSEQ,GMRCBUF Q
- LKUP S DIC="^GMR(123.5,",DIC(0)="MNEQZ",DIC("W")="W "" "",$P(Y,""^"",2)",DIC("S")="I +$P(^(0),U,2)<2" D ^DIC K DIC I '$D(Y(0)) D LSRV Q
- I $P(Y(0),"^",2)=1 S GMRCSTXT(0)=Y(0,0),GMRCDG=+Y,GMRC1=1 D LSRV1 Q
- S:+Y>0 GMRCDG=+Y
- Q
- LSRV S GMRC1=0,GMRCDG=$O(^GMR(123.5,"B",GMRCSTXT(0),0)) Q:'GMRCDG
- LSRV1 I X'["??" W @IOF,GMRCSTXT(0) F I=0:0 S I=$O(^GMR(123.5,GMRCDG,10,I)) Q:I'>0 Q:$D(DUOUT) D
- .I $D(^GMR(123.5,GMRCDG,10,I,0)) D Q:$D(DUOUT) I $D(^GMR(123.5,+^(0),0)),$P(^GMR(123.5,+^GMR(123.5,GMRCDG,10,I,0),0),U,2)<9 W !,?2,$P(^(0),U)
- ..I $Y>(IOSL-4) D READ^GMRCASV W:'$D(DUOUT) @IOF
- I X["??" S GMRCSTXT(0)="ALL SERVICES",GMRCSEL="DISP" W @IOF D EN^GMRCASV
- S GMRCDG=0 I GMRCSTXT(0)'="ALL SERVICES" S GMRCSTXT(0)="ALL SERVICES"
- K DUOUT,DIROUT W !
- Q
- GMRCPS ;SLC/KCM,DLT -Select Service/specialty to send Consult to ;5/20/98 14:20
- +1 ;;3.0;CONSULT/REQUEST TRACKING;**1**;DEC 27, 1997
- ASRV WRITE !
- DO SERV
- IF GMRCDG
- DO SERV1
- +1 QUIT
- SERV ;Select from Hierarchy of services defined in 123.5
- +1 KILL X
- NEW GMRC1
- SET GMRCSTXT="Service/Specialty"
- SET GMRCSTXT(0)="ALL SERVICES"
- SET GMRCDG=0
- SET GMRC1=0
- +2 FOR
- WRITE !,"Select 'TO' Service/Specialty: "
- READ X:DTIME
- IF '$LENGTH(X)&(GMRC1=0)
- SET X="^"
- IF X["^^"
- SET DIROUT=1
- IF X["^"
- QUIT
- IF GMRC1=1&('$LENGTH(X))
- SET X="?"
- IF GMRC1=1
- SET GMRC1=0
- DO @$SELECT(X["?":"LSRV",1:"LKUP")
- IF GMRCDG
- SET GMRCDGT=GMRCDG
- QUIT
- +3 IF 'GMRCDG
- SET GMRCACT("D")="Redisplay Screen"
- +4 KILL GMRCSTXT,DUOUT,DIROUT
- QUIT
- SERV1 ;
- +1 SET GMRCBUF=GMRCDG
- +2 IF GMRCBUF>0
- KILL GMRCGRP
- SET GMRCSEL="BILD"
- DO EN^GMRCASV
- SET GMRCGRP("NAM")=^GMR(123.5,GMRCBUF,0)
- SET GMRCGRP("ROOT")=GMRCBUF
- SET GMRCGRP("NAM")=$SELECT($LENGTH($PIECE(GMRCGRP("NAM"),"^",3)):$PIECE(GMRCGRP("NAM"),"^",3),1:$EXTRACT($PIECE(GMRCGRP("NAM"),"^"),1,5))
- +3 IF $PIECE(^GMR(123.5,GMRCBUF,0),"^",1)'="ALL SERVICES"
- +4 KILL GMRCDG,GMRCSEQ,GMRCBUF
- QUIT
- LKUP SET DIC="^GMR(123.5,"
- SET DIC(0)="MNEQZ"
- SET DIC("W")="W "" "",$P(Y,""^"",2)"
- SET DIC("S")="I +$P(^(0),U,2)<2"
- DO ^DIC
- KILL DIC
- IF '$DATA(Y(0))
- DO LSRV
- QUIT
- +1 IF $PIECE(Y(0),"^",2)=1
- SET GMRCSTXT(0)=Y(0,0)
- SET GMRCDG=+Y
- SET GMRC1=1
- DO LSRV1
- QUIT
- +2 IF +Y>0
- SET GMRCDG=+Y
- +3 QUIT
- LSRV SET GMRC1=0
- SET GMRCDG=$ORDER(^GMR(123.5,"B",GMRCSTXT(0),0))
- IF 'GMRCDG
- QUIT
- LSRV1 IF X'["??"
- WRITE @IOF,GMRCSTXT(0)
- FOR I=0:0
- SET I=$ORDER(^GMR(123.5,GMRCDG,10,I))
- IF I'>0
- QUIT
- IF $DATA(DUOUT)
- QUIT
- Begin DoDot:1
- +1 IF $DATA(^GMR(123.5,GMRCDG,10,I,0))
- Begin DoDot:2
- +2 IF $Y>(IOSL-4)
- DO READ^GMRCASV
- IF '$DATA(DUOUT)
- WRITE @IOF
- End DoDot:2
- IF $DATA(DUOUT)
- QUIT
- IF $DATA(^GMR(123.5,+^(0),0))
- IF $PIECE(^GMR(123.5,+^GMR(123.5,GMRCDG,10,I,0),0),U,2)<9
- WRITE !,?2,$PIECE(^(0),U)
- End DoDot:1
- +3 IF X["??"
- SET GMRCSTXT(0)="ALL SERVICES"
- SET GMRCSEL="DISP"
- WRITE @IOF
- DO EN^GMRCASV
- +4 SET GMRCDG=0
- IF GMRCSTXT(0)'="ALL SERVICES"
- SET GMRCSTXT(0)="ALL SERVICES"
- +5 KILL DUOUT,DIROUT
- WRITE !
- +6 QUIT
