GMRCSLM ;SLC/DCM,JFR - List Mgr routine for consult tracking list ;9/8/99 14:52
;;3.0;CONSULT/REQUEST TRACKING;**1,4,14,12,22**;DEC 27, 1997
EN ; -- main entry point for GMRC CONSULT TRACKING
K GMRCOER
S GMRCEN=1 K GMRCQUT
;IF Consults
I $D(GMRCIS) D I $D(GMRCQUT) K GMRCEN,GMRCIS,GMRCQUT Q
.N DIR,DIRUT,DTOUT,DUOUT,Y
.S DIR(0)="SB^R:REQUESTING;C:CONSULTING"
.S DIR("A")="Are you the Requesting site or the Consulting site"
.D ^DIR I $D(DIRUT) S GMRCQUT=1 Q
.S GMRCIS=Y
D SP K GMRCEN I $D(GMRCQUT) K GMRCQUT Q
D EN^VALM("GMRC CONSULT TRACKING")
Q
;
HDR ; -- header code
;override title if IF Consults
I $D(GMRCIS) S VALM("TITLE")="IFC Requests: "_$S(GMRCIS="R":"Requesting",1:"Consulting")_" Site"
D HDR1 ;format line 1 of header
D:$L(GMRCWT) HDR2("")
Q
;
HDR1 ;format VALMHDR(1) with patient information
N GMRCX,GMRCX1,GMRCX2,GMRCX3,TIUCWAD,GMRVSTR,X
;Expects DFN
S GMRVSTR="WT" D EN6^GMRVUTL
S GMRCWT="Wt.(lb): "_$S($L($P(X,U,8)):$P(X,U,8),1:"No Entry")
D DEM^GMRCU ;returns GMRCPNM,GMRCSN,GMRCAGE,SEX,GMRCWARD,GMRCRB,GMRCDOB,GMRCWLI
S GMRCX1=GMRCPNM_" "_GMRCSN
;
S GMRCLOC=+$G(^DIC(42,+GMRCWLI,44))_";SC(" I 'GMRCLOC,'$D(XQAID) S GMRCLOC=""
S GMRCX2="" I +$G(GMRCLOC) D
. N L S L=$G(^SC(+GMRCLOC,0)),GMRCX2=$P(L,U,2)
. S:'$L(GMRCX2) GMRCX2=$E($P(L,U),1,4)
S:$L($G(GMRCRB)) GMRCX2=GMRCX2_"/"_GMRCRB
;
S GMRCX=GMRCX1_$J(GMRCX2,40+($L(GMRCX2)\2)-$L(GMRCX1))
S GMRCX3=" "_GMRCDOB_" ("_GMRCAGE_")"
S TIUCWAD=$$CWAD^ORQPT2(+DFN) S:TIUCWAD]"" GMRCX3=GMRCX3_" <"_TIUCWAD_">"
S VALMHDR(1)=GMRCX_$J(GMRCX3,79-$L(GMRCX))
K VALMHDR(2)
Q
HDR2(GMRCX) ;format VALMHDR(2) with patient weight
S VALMHDR(2)=$G(GMRCX)_$J($G(GMRCWT),79-$L($G(GMRCX)))
Q
;
INIT ; -- init variables and list array
K ^TMP("GMRCR",$J,"LIST")
S DSPLINE=0,DATA="",VALMAR="^TMP(""GMRCR"",$J,""LIST"")"
F LINE=1:1:LNCT S DSPLINE=$O(^TMP("GMRCR",$J,"CS",DSPLINE)) Q:DSPLINE=""!(DSPLINE?1A.E) S DATA=^(DSPLINE,0) D SET^VALM10(LINE,DATA)
S VALMCNT=LNCT,VALMPGE=1,XQORM("A")="Select Action: "
K DSPLINE,DATA,LINE
S:$D(^TMP("GMRC",$J,"CURRENT","MENU")) XQORM("HIJACK")=^("MENU")
Q
;
HELP ; -- help code
N X,DX,DY D FULL^VALM1
W !!,"Enter the display number of the item you wish to act on, or select an action."
W !!,"If you'd like another view of the consults, enter CV."
W !!,"Status key:",!?5,"'a' - active",?27,"'c' - complete",?50,"'dc' - discontinued",!?5,"'p' - pending",?27,"'x' - cancelled",?50,"'pr' - partial results",!?5,"'s' - scheduled",?27,"'e' - expired"
W !!,"Enter ?? to see a list of actions available for navigating the list."
W !!,"Press <return> to continue ..." R X:DTIME
S VALMBCK="R"
; S VALMSG=$$MSG
S (DX,DY)=0 X ^%ZOSF("XY")
D EXIT^GMRCSLMA("R")
Q
;
EXIT ; -- exit code
K ^TMP("GMRCR",$J,"LIST")
K VALMCNT,VALMBCK,VALMPGE
D ^GMRCREXT
Q
;
PHYEN ;Entry Point When Provider's service is known and only needs to look at consults for that service
Q:'$D(DUZ) Q:'$D(^VA(200,DUZ,5)) Q:'$L(^VA(200,DUZ,5))
S DIC="^DIC(49,",DIC(0)="MNO",X=^VA(200,DUZ,5) D ^DIC K DIC S GMRCSSNM=$S($L($P(Y,"^",2)):$P(Y,"^",2),1:"") I $L(GMRCSSNM) S GMRCSS=$O(^GMR(123.5,"B",GMRCSSNM,0))
S GMRCFL=1 D SP I $D(GMRCQUT),GMRCQUT=1 Q
D SPD I $D(GMRCQUT) D END,EXIT Q
K GMRCFL
D AD^GMRCSLM1
I GMRCSSNM'["MEDICINE" D EN^VALM("GMRC CONSULT TRACKING"),END,EXIT Q
D EN^VALM("GMRC TRK MEDICINE CONSULTS"),END,EXIT Q
Q
SP ;;Select a new patient and return DFN and GMRCSSNM to display consults and requested Service.
I $D(VALM) D FULL^VALM1
K GMRCQUT S GMRCDFN1=$S($D(DFN):DFN,1:0)
D SELPT^GMRCS I $S($D(GMRCQUT):1,'$D(DFN):1,1:0) S GMRCQUT=1,DFN=GMRCDFN1 G SPK
I $D(Y),Y<0&(X["^") S GMRCQUT=1 G SPK
I $D(Y),Y<0 S DFN=GMRCDFN1 S GMRCQUT=1 G SPK
I $D(GMRC("NMBR")) D RESET^GMRCSLMV(GMRC("NMBR")) K GMRC("NMBR")
S GMRCWRD=GMRCWARD
I $D(GMRCFL) D SPK Q
D ASRV^GMRCASV I $S($D(GMRCQUT):1,$D(DTOUT):1,$D(DUOUT):1,1:0) K DTOUT,DIROUT,DUOUT S (GMRCQUT,GMRCQIT)=1 Q
S GMRCSS=GMRCDG,GMRCSSNM=$P(^GMR(123.5,GMRCSS,0),"^",1) S GMRCSTCK=""
D EN^GMRCMENU
SPD ;Enter a date range for serching consults; null entry selects all consults and does not exclude by date
D ^GMRCSPD Q:$D(GMRCQUT)
I $D(GMRCEN) D SPK Q ;GMRCEN defined if branched to here from EN^GMRCSLM
S GMRCOER=0
D AD^GMRCSLM1 ;Do not delete. Needed to get new Pt. data into ^TMP("GMRCR",
S VALMCNT=LNCT,VALMBCK="R",VALMPGE=1 K GMRCDFN1
Q
SPQ ;New patient has not been selected - keep current patient
I '$D(DFN),GMRCDFN1<1 S GMRCQUT=1 K GMRCDFN1 Q
S DFN=GMRCDFN1 Q:DFN<1 W " "_GMRCPNM K GMRCDFN1
S VALMBCK="R",GMRCQUT=1 K GMRCDFN1
SPK ;Kill variables
;I $D(GMRCTM),$D(GMRCBM),$D(IOSTBM) S IOTM=GMRCTM,IOBM=IOSTBM
K GMRCDFN1,GMRCBM,GMRCTM
Q
SS ;Select A New Service or ALL SERVICES to Display Patient Consults
K GMRCQUT,GMRCVP S GMRCOER=0
D FULL^VALM1
D ASRV^GMRCASV I $D(GMRCQUT),GMRCQUT=1 Q
S GMRCSS=GMRCDG,GMRCSSNM=$P(^GMR(123.5,GMRCSS,0),"^",1)
D AD^GMRCSLM1,INIT,HDR
S VALMBCK="R",VALMCNT=LNCT
D EN^GMRCACTM,EN^GMRCMENU
I $D(GMRC("NMBR")) D RESET^GMRCSLMV(GMRC("NMBR")) K GMRC("NMBR")
Q
STS ;Select a status for view. i.e., only active, pendings, DC'd, etc.
I $D(IOTM),$D(IOBM),$D(IOSTBM) D FULL^VALM1
S GMRCERR=0
N DIR,X,Y
S DIR(0)="SAOM^dc:Discontinued;c:Complete;p:Pending;a:Active;pr:Partial Results;s:Scheduled;x:Cancelled"
S $P(DIR(0),U,2)="al:All Status's;"_$P(DIR(0),U,2)
S DIR("A")="Only Display Consults With Status of: "
S DIR("B")="All Status's"
I $G(GMRCSTCK) D
. S DIR("A")="Another Status to display: "
. K DIR("B")
D ^DIR
I $D(DUOUT)!($D(DTOUT))!('$L(Y)) G END
D STCK($$LOW^XLFSTR(Y)) I $G(GMRCSTCK)="" D:$D(GMRC("NMBR")) G END
. D RESET^GMRCSLMV(GMRC("NMBR"))
. K GMRC("NMBR")
. Q
I $D(GMRC("NMBR")) D RESET^GMRCSLMV(GMRC("NMBR")) K GMRC("NMBR")
G STS
STCK(RES) ;change code to status
N CODE
I RES="al" S GMRCSTCK="" Q
I RES="dc" S CODE=1
I RES="c" S CODE=2
I RES="p" S CODE=5
I RES="a" S CODE=6
I RES="pr" S CODE=9
I RES="x" S CODE=13
I RES="s" S CODE=8
I $D(GMRCSTCK) I $$FND(CODE) W $C(7),!,"Already selected" Q
I +$G(GMRCSTCK) S GMRCSTCK=GMRCSTCK_","_CODE Q
S GMRCSTCK=CODE
Q
FND(CD) ;status already selected?
I GMRCSTCK=CD Q 1
I $F(GMRCSTCK,(CD_",")) Q 1
I $E(GMRCSTCK,$L(GMRCSTCK))=CD Q 1
Q 0
END K DIR,GMRCERR,Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCSLM 6352 printed Sep 23, 2025@19:23:11 Page 2
GMRCSLM ;SLC/DCM,JFR - List Mgr routine for consult tracking list ;9/8/99 14:52
+1 ;;3.0;CONSULT/REQUEST TRACKING;**1,4,14,12,22**;DEC 27, 1997
EN ; -- main entry point for GMRC CONSULT TRACKING
+1 KILL GMRCOER
+2 SET GMRCEN=1
KILL GMRCQUT
+3 ;IF Consults
+4 IF $DATA(GMRCIS)
Begin DoDot:1
+5 NEW DIR,DIRUT,DTOUT,DUOUT,Y
+6 SET DIR(0)="SB^R:REQUESTING;C:CONSULTING"
+7 SET DIR("A")="Are you the Requesting site or the Consulting site"
+8 DO ^DIR
IF $DATA(DIRUT)
SET GMRCQUT=1
QUIT
+9 SET GMRCIS=Y
End DoDot:1
IF $DATA(GMRCQUT)
KILL GMRCEN,GMRCIS,GMRCQUT
QUIT
+10 DO SP
KILL GMRCEN
IF $DATA(GMRCQUT)
KILL GMRCQUT
QUIT
+11 DO EN^VALM("GMRC CONSULT TRACKING")
+12 QUIT
+13 ;
HDR ; -- header code
+1 ;override title if IF Consults
+2 IF $DATA(GMRCIS)
SET VALM("TITLE")="IFC Requests: "_$SELECT(GMRCIS="R":"Requesting",1:"Consulting")_" Site"
+3 ;format line 1 of header
DO HDR1
+4 if $LENGTH(GMRCWT)
DO HDR2("")
+5 QUIT
+6 ;
HDR1 ;format VALMHDR(1) with patient information
+1 NEW GMRCX,GMRCX1,GMRCX2,GMRCX3,TIUCWAD,GMRVSTR,X
+2 ;Expects DFN
+3 SET GMRVSTR="WT"
DO EN6^GMRVUTL
+4 SET GMRCWT="Wt.(lb): "_$SELECT($LENGTH($PIECE(X,U,8)):$PIECE(X,U,8),1:"No Entry")
+5 ;returns GMRCPNM,GMRCSN,GMRCAGE,SEX,GMRCWARD,GMRCRB,GMRCDOB,GMRCWLI
DO DEM^GMRCU
+6 SET GMRCX1=GMRCPNM_" "_GMRCSN
+7 ;
+8 SET GMRCLOC=+$GET(^DIC(42,+GMRCWLI,44))_";SC("
IF 'GMRCLOC
IF '$DATA(XQAID)
SET GMRCLOC=""
+9 SET GMRCX2=""
IF +$GET(GMRCLOC)
Begin DoDot:1
+10 NEW L
SET L=$GET(^SC(+GMRCLOC,0))
SET GMRCX2=$PIECE(L,U,2)
+11 if '$LENGTH(GMRCX2)
SET GMRCX2=$EXTRACT($PIECE(L,U),1,4)
End DoDot:1
+12 if $LENGTH($GET(GMRCRB))
SET GMRCX2=GMRCX2_"/"_GMRCRB
+13 ;
+14 SET GMRCX=GMRCX1_$JUSTIFY(GMRCX2,40+($LENGTH(GMRCX2)\2)-$LENGTH(GMRCX1))
+15 SET GMRCX3=" "_GMRCDOB_" ("_GMRCAGE_")"
+16 SET TIUCWAD=$$CWAD^ORQPT2(+DFN)
if TIUCWAD]""
SET GMRCX3=GMRCX3_" <"_TIUCWAD_">"
+17 SET VALMHDR(1)=GMRCX_$JUSTIFY(GMRCX3,79-$LENGTH(GMRCX))
+18 KILL VALMHDR(2)
+19 QUIT
HDR2(GMRCX) ;format VALMHDR(2) with patient weight
+1 SET VALMHDR(2)=$GET(GMRCX)_$JUSTIFY($GET(GMRCWT),79-$LENGTH($GET(GMRCX)))
+2 QUIT
+3 ;
INIT ; -- init variables and list array
+1 KILL ^TMP("GMRCR",$JOB,"LIST")
+2 SET DSPLINE=0
SET DATA=""
SET VALMAR="^TMP(""GMRCR"",$J,""LIST"")"
+3 FOR LINE=1:1:LNCT
SET DSPLINE=$ORDER(^TMP("GMRCR",$JOB,"CS",DSPLINE))
if DSPLINE=""!(DSPLINE?1A.E)
QUIT
SET DATA=^(DSPLINE,0)
DO SET^VALM10(LINE,DATA)
+4 SET VALMCNT=LNCT
SET VALMPGE=1
SET XQORM("A")="Select Action: "
+5 KILL DSPLINE,DATA,LINE
+6 if $DATA(^TMP("GMRC",$JOB,"CURRENT","MENU"))
SET XQORM("HIJACK")=^("MENU")
+7 QUIT
+8 ;
HELP ; -- help code
+1 NEW X,DX,DY
DO FULL^VALM1
+2 WRITE !!,"Enter the display number of the item you wish to act on, or select an action."
+3 WRITE !!,"If you'd like another view of the consults, enter CV."
+4 WRITE !!,"Status key:",!?5,"'a' - active",?27,"'c' - complete",?50,"'dc' - discontinued",!?5,"'p' - pending",?27,"'x' - cancelled",?50,"'pr' - partial results",!?5,"'s' - scheduled",?27,"'e' - expired"
+5 WRITE !!,"Enter ?? to see a list of actions available for navigating the list."
+6 WRITE !!,"Press <return> to continue ..."
READ X:DTIME
+7 SET VALMBCK="R"
+8 ; S VALMSG=$$MSG
+9 SET (DX,DY)=0
XECUTE ^%ZOSF("XY")
+10 DO EXIT^GMRCSLMA("R")
+11 QUIT
+12 ;
EXIT ; -- exit code
+1 KILL ^TMP("GMRCR",$JOB,"LIST")
+2 KILL VALMCNT,VALMBCK,VALMPGE
+3 DO ^GMRCREXT
+4 QUIT
+5 ;
PHYEN ;Entry Point When Provider's service is known and only needs to look at consults for that service
+1 if '$DATA(DUZ)
QUIT
if '$DATA(^VA(200,DUZ,5))
QUIT
if '$LENGTH(^VA(200,DUZ,5))
QUIT
+2 SET DIC="^DIC(49,"
SET DIC(0)="MNO"
SET X=^VA(200,DUZ,5)
DO ^DIC
KILL DIC
SET GMRCSSNM=$SELECT($LENGTH($PIECE(Y,"^",2)):$PIECE(Y,"^",2),1:"")
IF $LENGTH(GMRCSSNM)
SET GMRCSS=$ORDER(^GMR(123.5,"B",GMRCSSNM,0))
+3 SET GMRCFL=1
DO SP
IF $DATA(GMRCQUT)
IF GMRCQUT=1
QUIT
+4 DO SPD
IF $DATA(GMRCQUT)
DO END
DO EXIT
QUIT
+5 KILL GMRCFL
+6 DO AD^GMRCSLM1
+7 IF GMRCSSNM'["MEDICINE"
DO EN^VALM("GMRC CONSULT TRACKING")
DO END
DO EXIT
QUIT
+8 DO EN^VALM("GMRC TRK MEDICINE CONSULTS")
DO END
DO EXIT
QUIT
+9 QUIT
SP ;;Select a new patient and return DFN and GMRCSSNM to display consults and requested Service.
+1 IF $DATA(VALM)
DO FULL^VALM1
+2 KILL GMRCQUT
SET GMRCDFN1=$SELECT($DATA(DFN):DFN,1:0)
+3 DO SELPT^GMRCS
IF $SELECT($DATA(GMRCQUT):1,'$DATA(DFN):1,1:0)
SET GMRCQUT=1
SET DFN=GMRCDFN1
GOTO SPK
+4 IF $DATA(Y)
IF Y<0&(X["^")
SET GMRCQUT=1
GOTO SPK
+5 IF $DATA(Y)
IF Y<0
SET DFN=GMRCDFN1
SET GMRCQUT=1
GOTO SPK
+6 IF $DATA(GMRC("NMBR"))
DO RESET^GMRCSLMV(GMRC("NMBR"))
KILL GMRC("NMBR")
+7 SET GMRCWRD=GMRCWARD
+8 IF $DATA(GMRCFL)
DO SPK
QUIT
+9 DO ASRV^GMRCASV
IF $SELECT($DATA(GMRCQUT):1,$DATA(DTOUT):1,$DATA(DUOUT):1,1:0)
KILL DTOUT,DIROUT,DUOUT
SET (GMRCQUT,GMRCQIT)=1
QUIT
+10 SET GMRCSS=GMRCDG
SET GMRCSSNM=$PIECE(^GMR(123.5,GMRCSS,0),"^",1)
SET GMRCSTCK=""
+11 DO EN^GMRCMENU
SPD ;Enter a date range for serching consults; null entry selects all consults and does not exclude by date
+1 DO ^GMRCSPD
if $DATA(GMRCQUT)
QUIT
+2 ;GMRCEN defined if branched to here from EN^GMRCSLM
IF $DATA(GMRCEN)
DO SPK
QUIT
+3 SET GMRCOER=0
+4 ;Do not delete. Needed to get new Pt. data into ^TMP("GMRCR",
DO AD^GMRCSLM1
+5 SET VALMCNT=LNCT
SET VALMBCK="R"
SET VALMPGE=1
KILL GMRCDFN1
+6 QUIT
SPQ ;New patient has not been selected - keep current patient
+1 IF '$DATA(DFN)
IF GMRCDFN1<1
SET GMRCQUT=1
KILL GMRCDFN1
QUIT
+2 SET DFN=GMRCDFN1
if DFN<1
QUIT
WRITE " "_GMRCPNM
KILL GMRCDFN1
+3 SET VALMBCK="R"
SET GMRCQUT=1
KILL GMRCDFN1
SPK ;Kill variables
+1 ;I $D(GMRCTM),$D(GMRCBM),$D(IOSTBM) S IOTM=GMRCTM,IOBM=IOSTBM
+2 KILL GMRCDFN1,GMRCBM,GMRCTM
+3 QUIT
SS ;Select A New Service or ALL SERVICES to Display Patient Consults
+1 KILL GMRCQUT,GMRCVP
SET GMRCOER=0
+2 DO FULL^VALM1
+3 DO ASRV^GMRCASV
IF $DATA(GMRCQUT)
IF GMRCQUT=1
QUIT
+4 SET GMRCSS=GMRCDG
SET GMRCSSNM=$PIECE(^GMR(123.5,GMRCSS,0),"^",1)
+5 DO AD^GMRCSLM1
DO INIT
DO HDR
+6 SET VALMBCK="R"
SET VALMCNT=LNCT
+7 DO EN^GMRCACTM
DO EN^GMRCMENU
+8 IF $DATA(GMRC("NMBR"))
DO RESET^GMRCSLMV(GMRC("NMBR"))
KILL GMRC("NMBR")
+9 QUIT
STS ;Select a status for view. i.e., only active, pendings, DC'd, etc.
+1 IF $DATA(IOTM)
IF $DATA(IOBM)
IF $DATA(IOSTBM)
DO FULL^VALM1
+2 SET GMRCERR=0
+3 NEW DIR,X,Y
+4 SET DIR(0)="SAOM^dc:Discontinued;c:Complete;p:Pending;a:Active;pr:Partial Results;s:Scheduled;x:Cancelled"
+5 SET $PIECE(DIR(0),U,2)="al:All Status's;"_$PIECE(DIR(0),U,2)
+6 SET DIR("A")="Only Display Consults With Status of: "
+7 SET DIR("B")="All Status's"
+8 IF $GET(GMRCSTCK)
Begin DoDot:1
+9 SET DIR("A")="Another Status to display: "
+10 KILL DIR("B")
End DoDot:1
+11 DO ^DIR
+12 IF $DATA(DUOUT)!($DATA(DTOUT))!('$LENGTH(Y))
GOTO END
+13 DO STCK($$LOW^XLFSTR(Y))
IF $GET(GMRCSTCK)=""
if $DATA(GMRC("NMBR"))
Begin DoDot:1
+14 DO RESET^GMRCSLMV(GMRC("NMBR"))
+15 KILL GMRC("NMBR")
+16 QUIT
End DoDot:1
GOTO END
+17 IF $DATA(GMRC("NMBR"))
DO RESET^GMRCSLMV(GMRC("NMBR"))
KILL GMRC("NMBR")
+18 GOTO STS
STCK(RES) ;change code to status
+1 NEW CODE
+2 IF RES="al"
SET GMRCSTCK=""
QUIT
+3 IF RES="dc"
SET CODE=1
+4 IF RES="c"
SET CODE=2
+5 IF RES="p"
SET CODE=5
+6 IF RES="a"
SET CODE=6
+7 IF RES="pr"
SET CODE=9
+8 IF RES="x"
SET CODE=13
+9 IF RES="s"
SET CODE=8
+10 IF $DATA(GMRCSTCK)
IF $$FND(CODE)
WRITE $CHAR(7),!,"Already selected"
QUIT
+11 IF +$GET(GMRCSTCK)
SET GMRCSTCK=GMRCSTCK_","_CODE
QUIT
+12 SET GMRCSTCK=CODE
+13 QUIT
FND(CD) ;status already selected?
+1 IF GMRCSTCK=CD
QUIT 1
+2 IF $FIND(GMRCSTCK,(CD_","))
QUIT 1
+3 IF $EXTRACT(GMRCSTCK,$LENGTH(GMRCSTCK))=CD
QUIT 1
+4 QUIT 0
END KILL DIR,GMRCERR,Y
+1 QUIT
