GMRCSLM1 ;SLC/DCM - Gather data and format ^TMP global for consult tracking Silent call for use by List Manager and GUI ;10/9/01 23:12
;;3.0;CONSULT/REQUEST TRACKING;**1,4,10,12,15,17,22,32,63**;DEC 27, 1997;Build 10
;
; This routine invokes IA #2638,#2740
;
G AD
SVC(NODE) ;Check for a valid service
K GMRCDEAV
I '$D(^GMR(123,NODE,0)) Q 0
I '+$P(^GMR(123,NODE,0),"^",5) Q 0
I '$D(^TMP("GMRCS",$J,$P(^GMR(123,NODE,0),"^",5))) Q 0
Q 1
AD ;Main entry point. Loop through AD x-ref in file 123; Find consults that have been released to requested service
;;DFN and GMRCSSNM must be defined when this entry point is called
;;DFN=Internal File Number of Patient in ^DPT
;;GMRCSSNM=Service Name of a Hospital Service from file ^GMR(123.5
;;If GMRCSSNM is not defined or is null, then no records will be found.
;;GMRCOER must be passed so that proper formatting for GUI or List Manager can be performed. GMRCOER is passed as 0 for List Manager, 1 for GUI.
;;GMRCDT1 and GMRCDT2 are passed in as start and stop dates for the lookup. If GMRCDT1="" or GMRCDT1="ALL", then all dates are searched.
;;GMRCIS=IFC site (if defined); Values: R(equesting) or C(onsulting)
;; ***********************************************************
K ^TMP("GMRCR",$J,"CS"),GMRCNUL
I $D(GMRCSSS) S (GMRCDG,GMRCSS)=GMRCSSS,GMRCSSNM=($P($G(^GMR(123.5,+GMRCSS,0)),"^",1)) D SERV1^GMRCASV K GMRCSSS ;reset after forward
S TAB="",$P(TAB," ",41)="",BLK=0,LNCT=1 S:'$D(GMRCOER) GMRCOER=0
S GMRCD=0 F S GMRCD=$O(^GMR(123,"AD",DFN,GMRCD)) Q:'GMRCD S GMRCDA=0 F S GMRCDA=$O(^GMR(123,"AD",DFN,GMRCD,GMRCDA)) Q:'GMRCDA I $$SVC(GMRCDA) D SET
D END Q
SET ;;Format entries into a word processing 'TMP("GMRCR",$J,"CS",' global that List Manager can display
;;GMRCOER is a variable that signals that data is being formatted for the OE/RR GUI; this data is formatted differently than the data for List Manager.
;;GMRCOER=0 : Data is List Manager formatted.
;;GMRCOER=1 : Data is OE/RR GUI formatted.
S:'$D(TAB) TAB="",$P(TAB," ",30)=""
S GMRCIFN=$G(GMRCDA) I '$L(GMRCIFN),$D(XQADATA) S (GMRCDA,GMRCIFN)=+XQADATA
I $G(XQADATA)["@" S (GMRCDA,GMRCIFN)=+$P($P(XQADATA,"@",2),"|",2)
S GMRCSEX=$S($P(^DPT(DFN,0),"^",2)="M":"MALE",1:"FEMALE")
I '$D(^GMR(123,+GMRCIFN,0)) S GMRCQUT=1 Q
S PROC="",GMRC(0)=^GMR(123,GMRCIFN,0)
;IF Consults
N GMRCCK
I $D(GMRCIS) D Q:'GMRCCK
. S GMRCCK=1
. S:'$P($G(GMRC(0)),"^",23) GMRCCK=0
. I GMRCCK=1 D
. . S GMRC(12)=$G(^GMR(123,GMRCIFN,12))
. . I GMRCIS="R",$P(GMRC(12),"^",5)'="P" S GMRCCK=0
. . I GMRCIS="C",$P(GMRC(12),"^",5)'="F" S GMRCCK=0
I $D(GMRCSTCK),GMRCSTCK'="" N STATUS,TITLE D Q:'STATUS
. N I
. F I=1:1 S STATUS=$P(GMRCSTCK,",",I) Q:STATUS=$P(GMRC(0),"^",12) Q:'STATUS
. Q
I $D(GMRCVP),GMRCVP'=$P(GMRC(0),"^",8) Q
S (GMRCFMDT,X)=$P(GMRC(0),"^",7) I GMRCDT1'="ALL",$P(X,".",1)<GMRCDT1!($P(X,".",1)>GMRCDT2) Q
I GMRCOER'=2 D
. S BLK=BLK+1
. S ^TMP("GMRCR",$J,"CS","AD",BLK,LNCT,GMRCDA)=""
D REGDTM^GMRCU S CDT=$P(X," ")
S PROC=$S($P(GMRC(0),U,17)="P":"Procedure",1:"Consult")
I PROC'="Consult" S PROC=$$GET1^DIQ(123.3,+$P(GMRC(0),"^",8),.01)
S:PROC="" PROC="Consult"
S TO=+$P(GMRC(0),"^",5)
I +TO S TOD=$S($P($G(^GMR(123.5,+TO,0)),"^",2)=9:1,1:0)
I '$D(TOD) S TOD=0
S TO=$S(+TO:$P($G(^GMR(123.5,+TO,0)),"^",1),1:"")
S TO=$S(TOD:"<",1:"")_TO
S TO=$S(GMRCOER:TO,1:$E(TO,1,40))_$S(TOD:">",1:"")
I '$L(TO) S TO="**Unknown Service**"
S STS=$P(GMRC(0),"^",12) D
. I '+STS,'$D(^ORD(100.01,+STS,0)) Q
. I '+GMRCOER S STS=$P(^ORD(100.01,+STS,.1),"^",1) Q
. I GMRCOER=1 S STS=$P(^ORD(100.01,+STS,0),"^") Q
. S STS=$P(^ORD(100.01,+STS,.1),"^")
I $S(STS="":1,'$D(^ORD(100.01,+$P(GMRC(0),"^",12),0)):1,1:0) S STS=99,$P(GMRC(0),"^",12)=STS,STS=$S(GMRCOER=1:$P(^ORD(100.01,5,0),"^",1),1:$P(^ORD(100.01,+STS,.1),"^",1))
D SERVPROC
I 'GMRCOER D Q
. S ^TMP("GMRCR",$J,"CS",LNCT,0)=BLK_$E(TAB,1,(4-$L(BLK)))_CDT_" "_$E(STS,1,3)_$S(STS?1A:" ",STS?2A:" ",1:"")_" "_$J(GMRCDA,7)_" "_$S($P(GMRC(0),"^",19)="Y":"*",1:" ")_TITLE
. S LNCT=LNCT+1
I GMRCOER D
. N DATA
. S DATA=GMRCDA_U_GMRCFMDT_U_STS_U_TO_U_PROC_U
. S DATA=DATA_$S($P(GMRC(0),U,19)="Y":"*",1:"")_U
. S DATA=DATA_TITLE_U_$P(GMRC(0),U,3)
. D ;get type of record for proper icon in GUI
.. ; "C"=reg cons, "P"=reg proc, "M"=clin proc, "I"=IF cons, "R"=IF proc
.. I +$G(^GMR(123,GMRCDA,1)) S $P(DATA,U,9)="M" Q
.. S $P(DATA,U,9)=$P(GMRC(0),U,17)
.. N GMRCGVER
.. S GMRCGVER=$P($G(ORWCLVER),".",3,4) ;GUI version running
.. I GMRCGVER'>19.1 Q ;will crash at less than 19.1
.. I $P(GMRC(0),U,23) S $P(DATA,U,9)=$S($P(DATA,U,9)="P":"R",1:"I")
. S ^TMP("GMRCR",$J,"CS",LNCT,0)=DATA
. S LNCT=LNCT+1
. K STSOER Q
Q
END I LNCT<2 S (BLK,LNCT,GMRCNUL)=1,GMRCNPM="< PATIENT DOES NOT HAVE ANY CONSULTS/REQUESTS "_$S($D(GMRCPRNM):"FOR "_GMRCPRNM,1:"")_" ON FILE. >",GMRCNPM=$E(TAB,1,(80-$L(GMRCNPM))\80)_GMRCNPM,^TMP("GMRCR",$J,"CS",LNCT,0)=GMRCNPM D
.I $D(GMRCDT1)&($D(GMRCDT2)),GMRCDT1'="ALL" S LNCT=LNCT+1,^TMP("GMRCR",$J,"CS",LNCT,0)="Between Dates: "_$$FMTE^XLFDT(GMRCDT1)_" and "_$$FMTE^XLFDT(GMRCDT2)
.I $D(GMRCSTCK),$L(GMRCSTCK) S LNCT=LNCT+1,^TMP("GMRCR",$J,"CS",LNCT,0)="With Status: " S STS="" F I=1:1 S STS=$P(GMRCSTCK,",",I) Q:STS="" S ^TMP("GMRCR",$J,"CS",LNCT,0)=^(0)_$P($G(^ORD(100.01,+STS,0)),"^",1)_" "
.Q
E S (BLK,LNCT)=LNCT-1,^TMP("GMRCR",$J,"CS",0)="^^^"_LNCT
I $D(GMRCALFL) S (BLK,LNCT)=1
K TO,TOD,END,FLG,GMRC(0),GMRCD,GMRCDG,GMRCIFN,GMRCFMDT,GMRCNPM,GMRCWARD
K I,PROC,STS,URG
Q
OER(DFN,GMRCDG,GMRCDT1,GMRCDT2,GMRCSTCK,GMRCOER) ;;GUI interface for CPRS
;;DFN=Patient internal file number
;;GMRCDG: Internal file number of consult service from file 123.5
;;GMRCDT1: Beginning date for lookup
;;GMRCDT2: Ending date for lookup
;;GMRCSTCK: IEN from OER Status File [^OER(100.01)] to screen results
;; so that only consults with a desired status are displayed
;; Can be sent as a set of statuses: i.e., 6,5,2
;; (GMRCSTCK=GMRC STATUS CHECK)
;;GMRCOER=0 if request is from CONSULTS
;; =1 if request is for CPRS List Manager
;; =2 if for CPRS GUI
I GMRCDT1="" S GMRCDT1="ALL"
I GMRCDG="" S GMRCDG=$O(^GMR(123.5,"B","ALL SERVICES",0))
S:'$D(GMRCOER) GMRCOER=1
D SERV1^GMRCASV,AD
K ^TMP("GMRCS",$J),^TMP("GMRCSLIST",$J)
Q
SERVPROC ; Build contents of SERV/PROC field for List Manager
N TYPE,OTXT
S TITLE=""
S TYPE=""
S OTXT=$P($G(^GMR(123,GMRCDA,1.11)),"^")
I OTXT="" D BUILD2
I OTXT'="" D BUILD1
Q
BUILD1 ;OTXT does contain information
N FLG,BADFLG,TPROC,TTO,LEN,ABBRS,ABBRP
S TPROC=$$UP^XLFSTR(PROC),TTO=$$UP^XLFSTR(TO)
S TITLE=OTXT,OTXT=$$UP^XLFSTR(OTXT)
S BADFLG=0
I PROC="Consult" S FLG=1,TYPE="Cons"
I PROC'="Consult" S FLG=0,TYPE="Proc"
S LEN=$L(TITLE)
I TO="" S TO="No Service"
I LEN<30,FLG=1,OTXT'=TTO S TITLE=TITLE_" "_TO_" "_TYPE Q
I LEN<30,FLG=1,OTXT=TTO S TITLE=TITLE_" "_TYPE Q
I TO["<" S BADFLG=1
S ABBRS=$$SVC^GMRCAU(GMRCDA),ABBRP=$$PROC^GMRCAU(GMRCDA)
I LEN<30,FLG=0,TPROC'=OTXT,TTO'=TPROC S TITLE=TITLE_" "_PROC_" "_TO_" "_TYPE Q
I LEN<30,FLG=0,TPROC=OTXT,TTO'=TPROC S TITLE=TITLE_" "_TO_" "_TYPE Q
I LEN<30,FLG=0,TPROC=OTXT,TTO=TPROC S TITLE=TITLE_" "_TYPE Q
I LEN>30,FLG=1,TTO'=OTXT S TITLE=TITLE_" "_TO_" "_TYPE Q
I LEN>30,FLG=1,TTO=OTXT S TITLE=TITLE_" "_TYPE Q
I LEN>30,FLG=0,TPROC'=OTXT,TTO'=TPROC S TITLE=TITLE_" "_ABBRP_" "_TYPE Q
I LEN>30,FLG=0,TTO'=OTXT,BADFLG=0 S TITLE=TITLE_" "_ABBRS_" "_TYPE Q
I LEN>30,FLG=0,TTO'=OTXT,BADFLG=1 S TITLE=TITLE_" "_"<"_ABBRS_">"_TYPE Q
Q
BUILD2 ;OTXT contains no information
N FLG,TPROC,TTO,LEN
S TPROC=$$UP^XLFSTR(PROC),TTO=$$UP^XLFSTR(TO)
I PROC="Consult" S TITLE=TO,LEN=$L(TITLE),FLG=1,TYPE="Cons"
I PROC'="Consult" S TITLE=PROC,LEN=$L(TITLE),FLG=0,TYPE="Proc"
I FLG=1 S TITLE=TITLE_" "_TYPE Q
I FLG=0,TTO=TPROC S TITLE=TITLE_" "_TYPE Q
I FLG=0,TTO'=TPROC S TITLE=TITLE_" "_TO_" "_TYPE Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCSLM1 7931 printed Oct 16, 2024@17:47:59 Page 2
GMRCSLM1 ;SLC/DCM - Gather data and format ^TMP global for consult tracking Silent call for use by List Manager and GUI ;10/9/01 23:12
+1 ;;3.0;CONSULT/REQUEST TRACKING;**1,4,10,12,15,17,22,32,63**;DEC 27, 1997;Build 10
+2 ;
+3 ; This routine invokes IA #2638,#2740
+4 ;
+5 GOTO AD
SVC(NODE) ;Check for a valid service
+1 KILL GMRCDEAV
+2 IF '$DATA(^GMR(123,NODE,0))
QUIT 0
+3 IF '+$PIECE(^GMR(123,NODE,0),"^",5)
QUIT 0
+4 IF '$DATA(^TMP("GMRCS",$JOB,$PIECE(^GMR(123,NODE,0),"^",5)))
QUIT 0
+5 QUIT 1
AD ;Main entry point. Loop through AD x-ref in file 123; Find consults that have been released to requested service
+1 ;;DFN and GMRCSSNM must be defined when this entry point is called
+2 ;;DFN=Internal File Number of Patient in ^DPT
+3 ;;GMRCSSNM=Service Name of a Hospital Service from file ^GMR(123.5
+4 ;;If GMRCSSNM is not defined or is null, then no records will be found.
+5 ;;GMRCOER must be passed so that proper formatting for GUI or List Manager can be performed. GMRCOER is passed as 0 for List Manager, 1 for GUI.
+6 ;;GMRCDT1 and GMRCDT2 are passed in as start and stop dates for the lookup. If GMRCDT1="" or GMRCDT1="ALL", then all dates are searched.
+7 ;;GMRCIS=IFC site (if defined); Values: R(equesting) or C(onsulting)
+8 ;; ***********************************************************
+9 KILL ^TMP("GMRCR",$JOB,"CS"),GMRCNUL
+10 ;reset after forward
IF $DATA(GMRCSSS)
SET (GMRCDG,GMRCSS)=GMRCSSS
SET GMRCSSNM=($PIECE($GET(^GMR(123.5,+GMRCSS,0)),"^",1))
DO SERV1^GMRCASV
KILL GMRCSSS
+11 SET TAB=""
SET $PIECE(TAB," ",41)=""
SET BLK=0
SET LNCT=1
if '$DATA(GMRCOER)
SET GMRCOER=0
+12 SET GMRCD=0
FOR
SET GMRCD=$ORDER(^GMR(123,"AD",DFN,GMRCD))
if 'GMRCD
QUIT
SET GMRCDA=0
FOR
SET GMRCDA=$ORDER(^GMR(123,"AD",DFN,GMRCD,GMRCDA))
if 'GMRCDA
QUIT
IF $$SVC(GMRCDA)
DO SET
+13 DO END
QUIT
SET ;;Format entries into a word processing 'TMP("GMRCR",$J,"CS",' global that List Manager can display
+1 ;;GMRCOER is a variable that signals that data is being formatted for the OE/RR GUI; this data is formatted differently than the data for List Manager.
+2 ;;GMRCOER=0 : Data is List Manager formatted.
+3 ;;GMRCOER=1 : Data is OE/RR GUI formatted.
+4 if '$DATA(TAB)
SET TAB=""
SET $PIECE(TAB," ",30)=""
+5 SET GMRCIFN=$GET(GMRCDA)
IF '$LENGTH(GMRCIFN)
IF $DATA(XQADATA)
SET (GMRCDA,GMRCIFN)=+XQADATA
+6 IF $GET(XQADATA)["@"
SET (GMRCDA,GMRCIFN)=+$PIECE($PIECE(XQADATA,"@",2),"|",2)
+7 SET GMRCSEX=$SELECT($PIECE(^DPT(DFN,0),"^",2)="M":"MALE",1:"FEMALE")
+8 IF '$DATA(^GMR(123,+GMRCIFN,0))
SET GMRCQUT=1
QUIT
+9 SET PROC=""
SET GMRC(0)=^GMR(123,GMRCIFN,0)
+10 ;IF Consults
+11 NEW GMRCCK
+12 IF $DATA(GMRCIS)
Begin DoDot:1
+13 SET GMRCCK=1
+14 if '$PIECE($GET(GMRC(0)),"^",23)
SET GMRCCK=0
+15 IF GMRCCK=1
Begin DoDot:2
+16 SET GMRC(12)=$GET(^GMR(123,GMRCIFN,12))
+17 IF GMRCIS="R"
IF $PIECE(GMRC(12),"^",5)'="P"
SET GMRCCK=0
+18 IF GMRCIS="C"
IF $PIECE(GMRC(12),"^",5)'="F"
SET GMRCCK=0
End DoDot:2
End DoDot:1
if 'GMRCCK
QUIT
+19 IF $DATA(GMRCSTCK)
IF GMRCSTCK'=""
NEW STATUS,TITLE
Begin DoDot:1
+20 NEW I
+21 FOR I=1:1
SET STATUS=$PIECE(GMRCSTCK,",",I)
if STATUS=$PIECE(GMRC(0),"^",12)
QUIT
if 'STATUS
QUIT
+22 QUIT
End DoDot:1
if 'STATUS
QUIT
+23 IF $DATA(GMRCVP)
IF GMRCVP'=$PIECE(GMRC(0),"^",8)
QUIT
+24 SET (GMRCFMDT,X)=$PIECE(GMRC(0),"^",7)
IF GMRCDT1'="ALL"
IF $PIECE(X,".",1)<GMRCDT1!($PIECE(X,".",1)>GMRCDT2)
QUIT
+25 IF GMRCOER'=2
Begin DoDot:1
+26 SET BLK=BLK+1
+27 SET ^TMP("GMRCR",$JOB,"CS","AD",BLK,LNCT,GMRCDA)=""
End DoDot:1
+28 DO REGDTM^GMRCU
SET CDT=$PIECE(X," ")
+29 SET PROC=$SELECT($PIECE(GMRC(0),U,17)="P":"Procedure",1:"Consult")
+30 IF PROC'="Consult"
SET PROC=$$GET1^DIQ(123.3,+$PIECE(GMRC(0),"^",8),.01)
+31 if PROC=""
SET PROC="Consult"
+32 SET TO=+$PIECE(GMRC(0),"^",5)
+33 IF +TO
SET TOD=$SELECT($PIECE($GET(^GMR(123.5,+TO,0)),"^",2)=9:1,1:0)
+34 IF '$DATA(TOD)
SET TOD=0
+35 SET TO=$SELECT(+TO:$PIECE($GET(^GMR(123.5,+TO,0)),"^",1),1:"")
+36 SET TO=$SELECT(TOD:"<",1:"")_TO
+37 SET TO=$SELECT(GMRCOER:TO,1:$EXTRACT(TO,1,40))_$SELECT(TOD:">",1:"")
+38 IF '$LENGTH(TO)
SET TO="**Unknown Service**"
+39 SET STS=$PIECE(GMRC(0),"^",12)
Begin DoDot:1
+40 IF '+STS
IF '$DATA(^ORD(100.01,+STS,0))
QUIT
+41 IF '+GMRCOER
SET STS=$PIECE(^ORD(100.01,+STS,.1),"^",1)
QUIT
+42 IF GMRCOER=1
SET STS=$PIECE(^ORD(100.01,+STS,0),"^")
QUIT
+43 SET STS=$PIECE(^ORD(100.01,+STS,.1),"^")
End DoDot:1
+44 IF $SELECT(STS="":1,'$DATA(^ORD(100.01,+$PIECE(GMRC(0),"^",12),0)):1,1:0)
SET STS=99
SET $PIECE(GMRC(0),"^",12)=STS
SET STS=$SELECT(GMRCOER=1:$PIECE(^ORD(100.01,5,0),"^",1),1:$PIECE(^ORD(100.01,+STS,.1),"^",1))
+45 DO SERVPROC
+46 IF 'GMRCOER
Begin DoDot:1
+47 SET ^TMP("GMRCR",$JOB,"CS",LNCT,0)=BLK_$EXTRACT(TAB,1,(4-$LENGTH(BLK)))_CDT_" "_$EXTRACT(STS,1,3)_$SELECT(STS?1A:" ",STS?2A:" ",1:"")_" "_$JUSTIFY(GMRCDA,7)_" "_$SELECT($PIECE(GMRC(0),"^",19)="Y":"*",1:" ")_TITLE
+48 SET LNCT=LNCT+1
End DoDot:1
QUIT
+49 IF GMRCOER
Begin DoDot:1
+50 NEW DATA
+51 SET DATA=GMRCDA_U_GMRCFMDT_U_STS_U_TO_U_PROC_U
+52 SET DATA=DATA_$SELECT($PIECE(GMRC(0),U,19)="Y":"*",1:"")_U
+53 SET DATA=DATA_TITLE_U_$PIECE(GMRC(0),U,3)
+54 ;get type of record for proper icon in GUI
Begin DoDot:2
+55 ; "C"=reg cons, "P"=reg proc, "M"=clin proc, "I"=IF cons, "R"=IF proc
+56 IF +$GET(^GMR(123,GMRCDA,1))
SET $PIECE(DATA,U,9)="M"
QUIT
+57 SET $PIECE(DATA,U,9)=$PIECE(GMRC(0),U,17)
+58 NEW GMRCGVER
+59 ;GUI version running
SET GMRCGVER=$PIECE($GET(ORWCLVER),".",3,4)
+60 ;will crash at less than 19.1
IF GMRCGVER'>19.1
QUIT
+61 IF $PIECE(GMRC(0),U,23)
SET $PIECE(DATA,U,9)=$SELECT($PIECE(DATA,U,9)="P":"R",1:"I")
End DoDot:2
+62 SET ^TMP("GMRCR",$JOB,"CS",LNCT,0)=DATA
+63 SET LNCT=LNCT+1
+64 KILL STSOER
QUIT
End DoDot:1
+65 QUIT
END IF LNCT<2
SET (BLK,LNCT,GMRCNUL)=1
SET GMRCNPM="< PATIENT DOES NOT HAVE ANY CONSULTS/REQUESTS "_$SELECT($DATA(GMRCPRNM):"FOR "_GMRCPRNM,1:"")_" ON FILE. >"
SET GMRCNPM=$EXTRACT(TAB,1,(80-$LENGTH(GMRCNPM))\80)_GMRCNPM
SET ^TMP("GMRCR",$JOB,"CS",LNCT,0)=GMRCNPM
Begin DoDot:1
+1 IF $DATA(GMRCDT1)&($DATA(GMRCDT2))
IF GMRCDT1'="ALL"
SET LNCT=LNCT+1
SET ^TMP("GMRCR",$JOB,"CS",LNCT,0)="Between Dates: "_$$FMTE^XLFDT(GMRCDT1)_" and "_$$FMTE^XLFDT(GMRCDT2)
+2 IF $DATA(GMRCSTCK)
IF $LENGTH(GMRCSTCK)
SET LNCT=LNCT+1
SET ^TMP("GMRCR",$JOB,"CS",LNCT,0)="With Status: "
SET STS=""
FOR I=1:1
SET STS=$PIECE(GMRCSTCK,",",I)
if STS=""
QUIT
SET ^TMP("GMRCR",$JOB,"CS",LNCT,0)=^(0)_$PIECE($GET(^ORD(100.01,+STS,0)),"^",1)_" "
+3 QUIT
End DoDot:1
+4 IF '$TEST
SET (BLK,LNCT)=LNCT-1
SET ^TMP("GMRCR",$JOB,"CS",0)="^^^"_LNCT
+5 IF $DATA(GMRCALFL)
SET (BLK,LNCT)=1
+6 KILL TO,TOD,END,FLG,GMRC(0),GMRCD,GMRCDG,GMRCIFN,GMRCFMDT,GMRCNPM,GMRCWARD
+7 KILL I,PROC,STS,URG
+8 QUIT
OER(DFN,GMRCDG,GMRCDT1,GMRCDT2,GMRCSTCK,GMRCOER) ;;GUI interface for CPRS
+1 ;;DFN=Patient internal file number
+2 ;;GMRCDG: Internal file number of consult service from file 123.5
+3 ;;GMRCDT1: Beginning date for lookup
+4 ;;GMRCDT2: Ending date for lookup
+5 ;;GMRCSTCK: IEN from OER Status File [^OER(100.01)] to screen results
+6 ;; so that only consults with a desired status are displayed
+7 ;; Can be sent as a set of statuses: i.e., 6,5,2
+8 ;; (GMRCSTCK=GMRC STATUS CHECK)
+9 ;;GMRCOER=0 if request is from CONSULTS
+10 ;; =1 if request is for CPRS List Manager
+11 ;; =2 if for CPRS GUI
+12 IF GMRCDT1=""
SET GMRCDT1="ALL"
+13 IF GMRCDG=""
SET GMRCDG=$ORDER(^GMR(123.5,"B","ALL SERVICES",0))
+14 if '$DATA(GMRCOER)
SET GMRCOER=1
+15 DO SERV1^GMRCASV
DO AD
+16 KILL ^TMP("GMRCS",$JOB),^TMP("GMRCSLIST",$JOB)
+17 QUIT
SERVPROC ; Build contents of SERV/PROC field for List Manager
+1 NEW TYPE,OTXT
+2 SET TITLE=""
+3 SET TYPE=""
+4 SET OTXT=$PIECE($GET(^GMR(123,GMRCDA,1.11)),"^")
+5 IF OTXT=""
DO BUILD2
+6 IF OTXT'=""
DO BUILD1
+7 QUIT
BUILD1 ;OTXT does contain information
+1 NEW FLG,BADFLG,TPROC,TTO,LEN,ABBRS,ABBRP
+2 SET TPROC=$$UP^XLFSTR(PROC)
SET TTO=$$UP^XLFSTR(TO)
+3 SET TITLE=OTXT
SET OTXT=$$UP^XLFSTR(OTXT)
+4 SET BADFLG=0
+5 IF PROC="Consult"
SET FLG=1
SET TYPE="Cons"
+6 IF PROC'="Consult"
SET FLG=0
SET TYPE="Proc"
+7 SET LEN=$LENGTH(TITLE)
+8 IF TO=""
SET TO="No Service"
+9 IF LEN<30
IF FLG=1
IF OTXT'=TTO
SET TITLE=TITLE_" "_TO_" "_TYPE
QUIT
+10 IF LEN<30
IF FLG=1
IF OTXT=TTO
SET TITLE=TITLE_" "_TYPE
QUIT
+11 IF TO["<"
SET BADFLG=1
+12 SET ABBRS=$$SVC^GMRCAU(GMRCDA)
SET ABBRP=$$PROC^GMRCAU(GMRCDA)
+13 IF LEN<30
IF FLG=0
IF TPROC'=OTXT
IF TTO'=TPROC
SET TITLE=TITLE_" "_PROC_" "_TO_" "_TYPE
QUIT
+14 IF LEN<30
IF FLG=0
IF TPROC=OTXT
IF TTO'=TPROC
SET TITLE=TITLE_" "_TO_" "_TYPE
QUIT
+15 IF LEN<30
IF FLG=0
IF TPROC=OTXT
IF TTO=TPROC
SET TITLE=TITLE_" "_TYPE
QUIT
+16 IF LEN>30
IF FLG=1
IF TTO'=OTXT
SET TITLE=TITLE_" "_TO_" "_TYPE
QUIT
+17 IF LEN>30
IF FLG=1
IF TTO=OTXT
SET TITLE=TITLE_" "_TYPE
QUIT
+18 IF LEN>30
IF FLG=0
IF TPROC'=OTXT
IF TTO'=TPROC
SET TITLE=TITLE_" "_ABBRP_" "_TYPE
QUIT
+19 IF LEN>30
IF FLG=0
IF TTO'=OTXT
IF BADFLG=0
SET TITLE=TITLE_" "_ABBRS_" "_TYPE
QUIT
+20 IF LEN>30
IF FLG=0
IF TTO'=OTXT
IF BADFLG=1
SET TITLE=TITLE_" "_"<"_ABBRS_">"_TYPE
QUIT
+21 QUIT
BUILD2 ;OTXT contains no information
+1 NEW FLG,TPROC,TTO,LEN
+2 SET TPROC=$$UP^XLFSTR(PROC)
SET TTO=$$UP^XLFSTR(TO)
+3 IF PROC="Consult"
SET TITLE=TO
SET LEN=$LENGTH(TITLE)
SET FLG=1
SET TYPE="Cons"
+4 IF PROC'="Consult"
SET TITLE=PROC
SET LEN=$LENGTH(TITLE)
SET FLG=0
SET TYPE="Proc"
+5 IF FLG=1
SET TITLE=TITLE_" "_TYPE
QUIT
+6 IF FLG=0
IF TTO=TPROC
SET TITLE=TITLE_" "_TYPE
QUIT
+7 IF FLG=0
IF TTO'=TPROC
SET TITLE=TITLE_" "_TO_" "_TYPE
QUIT
+8 QUIT
