GMRCSTL2 ;SLC/DCM,dee;MA - List Manager Format Routine - Get Active Consults by service - pending,active,scheduled,incomplete,etc. ;4/18/01 10:31
;;3.0;CONSULT/REQUEST TRACKING;**7,21,22,63**;DEC 27, 1997;Build 10
; Patch #21 changed array GMRCTOT to ^TMP("GMRCTOT",$J)
; Patch #21 also added a plus sign to the $P when setting
; GMRCDLA to check for a NULL value.
; This routine invokes IA #10035,#44, #10040
Q
;
ONESTAT(GMRCARRN) ;Process one status
; Input -- GMRCARRN List Template Array Name (Subscript)
; Values:
; "CP": pending consults; "IFC": inter-facility consults
; Output - None
S ^TMP("GMRCTOT",$J,1,GMRCSVC,STATUS)=0
S ^TMP("GMRCTOT",$J,2,GMRCSVC,STATUS)=0
S GMRCXDT=$S(GMRCDT1="ALL":0,1:9999999-GMRCDT2-.6)
F S GMRCXDT=$O(^GMR(123,"AE",GMRCSVC,STATUS,GMRCXDT)) Q:GMRCXDT=""!(GMRCXDT>(9999999-GMRCDT1)) D
.S GMRCPT=0
ONE .;Loop for one consult at a time
.F S GMRCPT=$O(^GMR(123,"AE",GMRCSVC,STATUS,GMRCXDT,GMRCPT)) Q:GMRCPT="" D
..; Check for bad "AE" x-ref
..I '$D(^GMR(123,GMRCPT,0)) D Q
...K ^GMR(123,"AE",GMRCSVC,STATUS,GMRCXDT,GMRCPT)
..S X=9999999-GMRCXDT
..D REGDTM^GMRCU
..S GMRCDT=$P(X," ",1)
..S GMRCDLA=$P(X," ",1)
..S GMRCD(0)=^GMR(123,GMRCPT,0)
..I GMRCARRN="IFC" D Q:'GMRCCK
...S GMRCCK=1
...S:'$D(GMRCIS) GMRCCK=0 S:'$P($G(GMRCD(0)),"^",23) GMRCCK=0
...I GMRCCK=1 D
....S GMRCD(12)=$G(^GMR(123,GMRCPT,12))
....I GMRCIS="R",$P(GMRCD(12),"^",5)'="P" S GMRCCK=0
....I GMRCIS="C",$P(GMRCD(12),"^",5)'="F" S GMRCCK=0
....I $D(GMRCREMP),$P(GMRCD(12),"^",6)'=GMRCREMP S GMRCCK=0
....I $D(GMRCRF),$P($G(GMRCD(0)),"^",23)'=GMRCRF S GMRCCK=0
..S GMRCPTN=$P(^DPT($P(GMRCD(0),"^",2),0),"^",1)
..S GMRCPTN=$P(GMRCPTN,",",1)_","_$E($P(GMRCPTN,",",2),1)_"."
..S GMRCPTSN="("_$E($P(^DPT($P(GMRCD(0),"^",2),0),"^",9),6,9)_")"
..; IF Consults
..I GMRCARRN="IFC" D
...N GMRCIRF,RCVDT,COMPLDT,ND
...S GMRCIRFN="NONE",GMRCIDD="N/A",GMRCRDT=""
...S GMRCIRF=$P($G(GMRCD(0)),"^",23)
... I GMRCIRF S GMRCIRFN=$E($$GET1^DIQ(4,GMRCIRF,.01),1,16)
...I '$D(^TMP("GMRCTOT",$J,1,GMRCSVC,"F",GMRCIRFN)) D
....S ^TMP("GMRCTOT",$J,1,GMRCSVC,"F",GMRCIRFN)=0
....S GMRCST(1,GMRCSVC,GMRCIRFN)="0^0"
...D GETDT^GMRCSTU(GMRCPT)
...I COMPLDT<9999999,$S(GMRCDT1="ALL":1,RCVDT'<GMRCDT1&(RCVDT'>GMRCDT2):1,1:0) D
....S X1=COMPLDT,X2=RCVDT D ^%DTC
....S GMRCIDD=X
...I GMRCIS="C" D
....S GMRCRDT=$$GETRDT(GMRCPT)
....I GMRCRDT]"" D
.....N X
.....S X=GMRCRDT D REGDT^GMRCU
.....S GMRCRDT=X
..S GMRCD=0
..S GMRCD=$O(^GMR(123,GMRCPT,40,"B",GMRCD))
..I GMRCD]"" D
...S GMRCDA=""
...S GMRCDA=$O(^GMR(123,+GMRCPT,40,"B",GMRCD,GMRCDA))
..S GMRCDLA=$E($P($G(^GMR(123.1,+$P(GMRCD(0),"^",13),0)),"^"),1,19)
..S GMRCLOC=$P(GMRCD(0),"^",4)
..S:$L(GMRCLOC) GMRCLOC=$P($G(^SC(GMRCLOC,0)),"^",1) ;DBIA#10040
..I '$L(GMRCLOC),$P(GMRCD(0),U,21) D
...S GMRCLOC=$$GET1^DIQ(4,$P(GMRCD(0),U,21),.01)
..I '$L(GMRCLOC),$P(GMRCD(0),U,23) D
...S GMRCLOC=$$GET1^DIQ(4,$P(GMRCD(0),U,23),.01)
..I GMRCARRN="IFC",$L(GMRCLOC) D
...S GMRCLOC=$E(GMRCLOC,1,23)
..I ^TMP("GMRCTOT",$J,1,GMRCSVC,"T")=0 D
...S GMRCCT=GMRCCT+1
...S ^TMP("GMRCR",$J,GMRCARRN,GMRCCT,0)=CTRLTEMP
...S GMRCCT=GMRCCT+1
...S TEMP="SERVICE: "_GMRCSVCP
...S:GMRCSVCG>0 TEMP=TEMP_" in Group: "_$P(^GMR(123.5,GMRCSVCG,0),"^",1)
...S ^TMP("GMRCR",$J,GMRCARRN,GMRCCT,0)=CTRLTEMP_TEMP
...S NUMCLIN=NUMCLIN+1
..S LINETEMP=""
CTRL ..I GMRCCTRL#100\10 D
...I GMRCCTRL#100\10=1 D
....S GMRCLINE=GMRCLINE+1
....S ^TMP("GMRCRINDEX",$J,GMRCLINE)=GMRCPT
....S LINETEMP=$J(GMRCLINE,4)_" "
...E S LINETEMP=$J(GMRCPT,9)_" "
..I GMRCCTRL#2 S LINETEMP=GMRCPT_"^"_LINETEMP
..I GMRCCTRL#1000\100 D
...S STS=$$STATABBR^GMRCSTL1(STATUS)
...S STS=STS_$J("",4-$L(STS)+1)
..E D
...S STS=$$STATNAME^GMRCSTL1(STATUS)
...S STS=STS_$J("",10-$L(STS)+1)
..S GMRCCT=GMRCCT+1
..S ^TMP("GMRCR",$J,GMRCARRN,GMRCCT,0)=LINETEMP_STS_GMRCDLA_$J("",20-$L(GMRCDLA))_GMRCDT_" "_GMRCPTN_" "_GMRCPTSN_$J("",12-$L(GMRCPTN)+5)_GMRCLOC
..; IF Consults
..I GMRCARRN="IFC" D
...S ^TMP("GMRCR",$J,GMRCARRN,GMRCCT,0)=^TMP("GMRCR",$J,GMRCARRN,GMRCCT,0)_$J("",25-$L(GMRCLOC))_GMRCIRFN_$J("",17-$L(GMRCIRFN))_" "_GMRCIDD_$J("",9-$L(GMRCIDD))_" "_GMRCRDT
...I '$D(GMRCCNSLT(GMRCPT)) S ^TMP("GMRCTOT",$J,1,GMRCSVC,"F",GMRCIRFN)=^TMP("GMRCTOT",$J,1,GMRCSVC,"F",GMRCIRFN)+1,GMRCCNSLT(GMRCPT)=""
...I GMRCIDD'="N/A" D
....S $P(GMRCST(1,GMRCSVC,GMRCIRFN),"^")=$P(GMRCST(1,GMRCSVC,GMRCIRFN),"^")+GMRCIDD
....S $P(GMRCST(1,GMRCSVC,GMRCIRFN),"^",2)=$P(GMRCST(1,GMRCSVC,GMRCIRFN),"^",2)+1
....S $P(GMRCST(1,GMRCSVC),"^")=$P(GMRCST(1,GMRCSVC),"^")+GMRCIDD
....S $P(GMRCST(1,GMRCSVC),"^",2)=$P(GMRCST(1,GMRCSVC),"^",2)+1
..;
ADDTOT ..;Add to totals
..; for all status for this service
..S ^TMP("GMRCTOT",$J,1,GMRCSVC,"T")=^TMP("GMRCTOT",$J,1,GMRCSVC,"T")+1
..; pending for this service
..S:",3,4,5,6,8,9,11,99,"[(","_STATUS_",") ^TMP("GMRCTOT",$J,1,GMRCSVC,"P")=^TMP("GMRCTOT",$J,1,GMRCSVC,"P")+1
..; this status (STATUS) for this service
..S ^TMP("GMRCTOT",$J,1,GMRCSVC,STATUS)=^TMP("GMRCTOT",$J,1,GMRCSVC,STATUS)+1
..; this status (STATUS) for services to all of its groupers
F GRP=GROUPER:-1:1 D
. I $D(^TMP("GMRCTOTX",$J,GROUPER(GRP),GMRCSVC,STATUS)) Q
. S ^TMP("GMRCTOT",$J,2,GROUPER(GRP),STATUS)=$G(^TMP("GMRCTOT",$J,2,GROUPER(GRP),STATUS))+^TMP("GMRCTOT",$J,1,GMRCSVC,STATUS),^TMP("GMRCTOTX",$J,GROUPER(GRP),GMRCSVC,STATUS)=""
Q
;
GETRDT(GMRCPT) ;get the received date
; Input:
; GMRCPT = File #123 IEN
; Output:
; GMRCRDT = Date of action entry for remote request received/received
N GMRCCKR,GMRCRDT,ND
S (GMRCCKR,ND)=0,GMRCRDT=""
F S ND=$O(^GMR(123,GMRCPT,40,ND)) Q:ND'>0!GMRCCKR D
.I $P(^GMR(123,GMRCPT,40,ND,0),"^",2)=23 D
..S GMRCRDT=$P(^GMR(123,GMRCPT,40,ND,0),"^"),GMRCCKR=1
.I $P(^GMR(123,GMRCPT,40,ND,0),"^",2)=21 D
..S GMRCRDT=$P(^GMR(123,GMRCPT,40,ND,0),"^")
Q GMRCRDT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCSTL2 5944 printed Sep 23, 2025@19:23:24 Page 2
GMRCSTL2 ;SLC/DCM,dee;MA - List Manager Format Routine - Get Active Consults by service - pending,active,scheduled,incomplete,etc. ;4/18/01 10:31
+1 ;;3.0;CONSULT/REQUEST TRACKING;**7,21,22,63**;DEC 27, 1997;Build 10
+2 ; Patch #21 changed array GMRCTOT to ^TMP("GMRCTOT",$J)
+3 ; Patch #21 also added a plus sign to the $P when setting
+4 ; GMRCDLA to check for a NULL value.
+5 ; This routine invokes IA #10035,#44, #10040
+6 QUIT
+7 ;
ONESTAT(GMRCARRN) ;Process one status
+1 ; Input -- GMRCARRN List Template Array Name (Subscript)
+2 ; Values:
+3 ; "CP": pending consults; "IFC": inter-facility consults
+4 ; Output - None
+5 SET ^TMP("GMRCTOT",$JOB,1,GMRCSVC,STATUS)=0
+6 SET ^TMP("GMRCTOT",$JOB,2,GMRCSVC,STATUS)=0
+7 SET GMRCXDT=$SELECT(GMRCDT1="ALL":0,1:9999999-GMRCDT2-.6)
+8 FOR
SET GMRCXDT=$ORDER(^GMR(123,"AE",GMRCSVC,STATUS,GMRCXDT))
if GMRCXDT=""!(GMRCXDT>(9999999-GMRCDT1))
QUIT
Begin DoDot:1
+9 SET GMRCPT=0
ONE ;Loop for one consult at a time
+1 FOR
SET GMRCPT=$ORDER(^GMR(123,"AE",GMRCSVC,STATUS,GMRCXDT,GMRCPT))
if GMRCPT=""
QUIT
Begin DoDot:2
+2 ; Check for bad "AE" x-ref
+3 IF '$DATA(^GMR(123,GMRCPT,0))
Begin DoDot:3
+4 KILL ^GMR(123,"AE",GMRCSVC,STATUS,GMRCXDT,GMRCPT)
End DoDot:3
QUIT
+5 SET X=9999999-GMRCXDT
+6 DO REGDTM^GMRCU
+7 SET GMRCDT=$PIECE(X," ",1)
+8 SET GMRCDLA=$PIECE(X," ",1)
+9 SET GMRCD(0)=^GMR(123,GMRCPT,0)
+10 IF GMRCARRN="IFC"
Begin DoDot:3
+11 SET GMRCCK=1
+12 if '$DATA(GMRCIS)
SET GMRCCK=0
if '$PIECE($GET(GMRCD(0)),"^",23)
SET GMRCCK=0
+13 IF GMRCCK=1
Begin DoDot:4
+14 SET GMRCD(12)=$GET(^GMR(123,GMRCPT,12))
+15 IF GMRCIS="R"
IF $PIECE(GMRCD(12),"^",5)'="P"
SET GMRCCK=0
+16 IF GMRCIS="C"
IF $PIECE(GMRCD(12),"^",5)'="F"
SET GMRCCK=0
+17 IF $DATA(GMRCREMP)
IF $PIECE(GMRCD(12),"^",6)'=GMRCREMP
SET GMRCCK=0
+18 IF $DATA(GMRCRF)
IF $PIECE($GET(GMRCD(0)),"^",23)'=GMRCRF
SET GMRCCK=0
End DoDot:4
End DoDot:3
if 'GMRCCK
QUIT
+19 SET GMRCPTN=$PIECE(^DPT($PIECE(GMRCD(0),"^",2),0),"^",1)
+20 SET GMRCPTN=$PIECE(GMRCPTN,",",1)_","_$EXTRACT($PIECE(GMRCPTN,",",2),1)_"."
+21 SET GMRCPTSN="("_$EXTRACT($PIECE(^DPT($PIECE(GMRCD(0),"^",2),0),"^",9),6,9)_")"
+22 ; IF Consults
+23 IF GMRCARRN="IFC"
Begin DoDot:3
+24 NEW GMRCIRF,RCVDT,COMPLDT,ND
+25 SET GMRCIRFN="NONE"
SET GMRCIDD="N/A"
SET GMRCRDT=""
+26 SET GMRCIRF=$PIECE($GET(GMRCD(0)),"^",23)
+27 IF GMRCIRF
SET GMRCIRFN=$EXTRACT($$GET1^DIQ(4,GMRCIRF,.01),1,16)
+28 IF '$DATA(^TMP("GMRCTOT",$JOB,1,GMRCSVC,"F",GMRCIRFN))
Begin DoDot:4
+29 SET ^TMP("GMRCTOT",$JOB,1,GMRCSVC,"F",GMRCIRFN)=0
+30 SET GMRCST(1,GMRCSVC,GMRCIRFN)="0^0"
End DoDot:4
+31 DO GETDT^GMRCSTU(GMRCPT)
+32 IF COMPLDT<9999999
IF $SELECT(GMRCDT1="ALL":1,RCVDT'<GMRCDT1&(RCVDT'>GMRCDT2):1,1:0)
Begin DoDot:4
+33 SET X1=COMPLDT
SET X2=RCVDT
DO ^%DTC
+34 SET GMRCIDD=X
End DoDot:4
+35 IF GMRCIS="C"
Begin DoDot:4
+36 SET GMRCRDT=$$GETRDT(GMRCPT)
+37 IF GMRCRDT]""
Begin DoDot:5
+38 NEW X
+39 SET X=GMRCRDT
DO REGDT^GMRCU
+40 SET GMRCRDT=X
End DoDot:5
End DoDot:4
End DoDot:3
+41 SET GMRCD=0
+42 SET GMRCD=$ORDER(^GMR(123,GMRCPT,40,"B",GMRCD))
+43 IF GMRCD]""
Begin DoDot:3
+44 SET GMRCDA=""
+45 SET GMRCDA=$ORDER(^GMR(123,+GMRCPT,40,"B",GMRCD,GMRCDA))
End DoDot:3
+46 SET GMRCDLA=$EXTRACT($PIECE($GET(^GMR(123.1,+$PIECE(GMRCD(0),"^",13),0)),"^"),1,19)
+47 SET GMRCLOC=$PIECE(GMRCD(0),"^",4)
+48 ;DBIA#10040
if $LENGTH(GMRCLOC)
SET GMRCLOC=$PIECE($GET(^SC(GMRCLOC,0)),"^",1)
+49 IF '$LENGTH(GMRCLOC)
IF $PIECE(GMRCD(0),U,21)
Begin DoDot:3
+50 SET GMRCLOC=$$GET1^DIQ(4,$PIECE(GMRCD(0),U,21),.01)
End DoDot:3
+51 IF '$LENGTH(GMRCLOC)
IF $PIECE(GMRCD(0),U,23)
Begin DoDot:3
+52 SET GMRCLOC=$$GET1^DIQ(4,$PIECE(GMRCD(0),U,23),.01)
End DoDot:3
+53 IF GMRCARRN="IFC"
IF $LENGTH(GMRCLOC)
Begin DoDot:3
+54 SET GMRCLOC=$EXTRACT(GMRCLOC,1,23)
End DoDot:3
+55 IF ^TMP("GMRCTOT",$JOB,1,GMRCSVC,"T")=0
Begin DoDot:3
+56 SET GMRCCT=GMRCCT+1
+57 SET ^TMP("GMRCR",$JOB,GMRCARRN,GMRCCT,0)=CTRLTEMP
+58 SET GMRCCT=GMRCCT+1
+59 SET TEMP="SERVICE: "_GMRCSVCP
+60 if GMRCSVCG>0
SET TEMP=TEMP_" in Group: "_$PIECE(^GMR(123.5,GMRCSVCG,0),"^",1)
+61 SET ^TMP("GMRCR",$JOB,GMRCARRN,GMRCCT,0)=CTRLTEMP_TEMP
+62 SET NUMCLIN=NUMCLIN+1
End DoDot:3
+63 SET LINETEMP=""
CTRL IF GMRCCTRL#100\10
Begin DoDot:3
+1 IF GMRCCTRL#100\10=1
Begin DoDot:4
+2 SET GMRCLINE=GMRCLINE+1
+3 SET ^TMP("GMRCRINDEX",$JOB,GMRCLINE)=GMRCPT
+4 SET LINETEMP=$JUSTIFY(GMRCLINE,4)_" "
End DoDot:4
+5 IF '$TEST
SET LINETEMP=$JUSTIFY(GMRCPT,9)_" "
End DoDot:3
+6 IF GMRCCTRL#2
SET LINETEMP=GMRCPT_"^"_LINETEMP
+7 IF GMRCCTRL#1000\100
Begin DoDot:3
+8 SET STS=$$STATABBR^GMRCSTL1(STATUS)
+9 SET STS=STS_$JUSTIFY("",4-$LENGTH(STS)+1)
End DoDot:3
+10 IF '$TEST
Begin DoDot:3
+11 SET STS=$$STATNAME^GMRCSTL1(STATUS)
+12 SET STS=STS_$JUSTIFY("",10-$LENGTH(STS)+1)
End DoDot:3
+13 SET GMRCCT=GMRCCT+1
+14 SET ^TMP("GMRCR",$JOB,GMRCARRN,GMRCCT,0)=LINETEMP_STS_GMRCDLA_$JUSTIFY("",20-$LENGTH(GMRCDLA))_GMRCDT_" "_GMRCPTN_" "_GMRCPTSN_$JUSTIFY("",12-$LENGTH(GMRCPTN)+5)_GMRCLOC
+15 ; IF Consults
+16 IF GMRCARRN="IFC"
Begin DoDot:3
+17 SET ^TMP("GMRCR",$JOB,GMRCARRN,GMRCCT,0)=^TMP("GMRCR",$JOB,GMRCARRN,GMRCCT,0)_$JUSTIFY("",25-$LENGTH(GMRCLOC))_GMRCIRFN_$JUSTIFY("",17-$LENGTH(GMRCIRFN))_" "_GMRCIDD_$JUSTIFY("",9-$LENGTH(GMRCIDD))_" "_GMRCRDT
+18 IF '$DATA(GMRCCNSLT(GMRCPT))
SET ^TMP("GMRCTOT",$JOB,1,GMRCSVC,"F",GMRCIRFN)=^TMP("GMRCTOT",$JOB,1,GMRCSVC,"F",GMRCIRFN)+1
SET GMRCCNSLT(GMRCPT)=""
+19 IF GMRCIDD'="N/A"
Begin DoDot:4
+20 SET $PIECE(GMRCST(1,GMRCSVC,GMRCIRFN),"^")=$PIECE(GMRCST(1,GMRCSVC,GMRCIRFN),"^")+GMRCIDD
+21 SET $PIECE(GMRCST(1,GMRCSVC,GMRCIRFN),"^",2)=$PIECE(GMRCST(1,GMRCSVC,GMRCIRFN),"^",2)+1
+22 SET $PIECE(GMRCST(1,GMRCSVC),"^")=$PIECE(GMRCST(1,GMRCSVC),"^")+GMRCIDD
+23 SET $PIECE(GMRCST(1,GMRCSVC),"^",2)=$PIECE(GMRCST(1,GMRCSVC),"^",2)+1
End DoDot:4
End DoDot:3
+24 ;
ADDTOT ;Add to totals
+1 ; for all status for this service
+2 SET ^TMP("GMRCTOT",$JOB,1,GMRCSVC,"T")=^TMP("GMRCTOT",$JOB,1,GMRCSVC,"T")+1
+3 ; pending for this service
+4 if ",3,4,5,6,8,9,11,99,"[(","_STATUS_",")
SET ^TMP("GMRCTOT",$JOB,1,GMRCSVC,"P")=^TMP("GMRCTOT",$JOB,1,GMRCSVC,"P")+1
+5 ; this status (STATUS) for this service
+6 SET ^TMP("GMRCTOT",$JOB,1,GMRCSVC,STATUS)=^TMP("GMRCTOT",$JOB,1,GMRCSVC,STATUS)+1
+7 ; this status (STATUS) for services to all of its groupers
End DoDot:2
End DoDot:1
+8 FOR GRP=GROUPER:-1:1
Begin DoDot:1
+9 IF $DATA(^TMP("GMRCTOTX",$JOB,GROUPER(GRP),GMRCSVC,STATUS))
QUIT
+10 SET ^TMP("GMRCTOT",$JOB,2,GROUPER(GRP),STATUS)=$GET(^TMP("GMRCTOT",$JOB,2,GROUPER(GRP),STATUS))+^TMP("GMRCTOT",$JOB,1,GMRCSVC,STATUS)
SET ^TMP("GMRCTOTX",$JOB,GROUPER(GRP),GMRCSVC,STATUS)=""
End DoDot:1
+11 QUIT
+12 ;
GETRDT(GMRCPT) ;get the received date
+1 ; Input:
+2 ; GMRCPT = File #123 IEN
+3 ; Output:
+4 ; GMRCRDT = Date of action entry for remote request received/received
+5 NEW GMRCCKR,GMRCRDT,ND
+6 SET (GMRCCKR,ND)=0
SET GMRCRDT=""
+7 FOR
SET ND=$ORDER(^GMR(123,GMRCPT,40,ND))
if ND'>0!GMRCCKR
QUIT
Begin DoDot:1
+8 IF $PIECE(^GMR(123,GMRCPT,40,ND,0),"^",2)=23
Begin DoDot:2
+9 SET GMRCRDT=$PIECE(^GMR(123,GMRCPT,40,ND,0),"^")
SET GMRCCKR=1
End DoDot:2
+10 IF $PIECE(^GMR(123,GMRCPT,40,ND,0),"^",2)=21
Begin DoDot:2
+11 SET GMRCRDT=$PIECE(^GMR(123,GMRCPT,40,ND,0),"^")
End DoDot:2
End DoDot:1
+12 QUIT GMRCRDT
