GMRCONS3 ;ALB/MRY - Consult Status link report ;4/10/06 14:21
;;3.0;CONSULT/REQUEST TRACKING;**52**;DEC 27, 1997
NEWSTS ;
N TEMPSTAT
S TEMPSTAT=GMRCSTAT
S GMRCSTAT=$$STS Q:GMRCSTAT=""
;S:$D(GMRCQUT) GMRCSTAT=TEMPSTAT
D CT3
Q
STS() ;Select a set of status for view.
I $D(IOTM),$D(IOBM),$D(IOSTBM) D FULL^VALM1
N DIR,X,Y,GMRCSTCK
STSAGAIN ;Loop to get another status.
S DIR(0)="SAOM^al:All Status's;ap:All Pending;dc:Discont.;c:Completed;p:Pending;a:Active;s:Scheduled;pr:Incomplete;x:Cancelled"
S DIR("A")="Only Display Consults With Status of: "
S DIR("B")="All Status's"
I $D(GMRCSTCK) D
. S DIR("A")="Another Status to display: "
. K DIR("B")
D ^DIR
I $D(DUOUT)!($D(DTOUT)) S GMRCQUT=1 G END
I '$L(Y) G END
D STCK($$LOW^XLFSTR(Y))
I $D(GMRCSTCK),GMRCSTCK'="COM,PEN,ACT,SCH,INC,DSC,CAN" G STSAGAIN
END Q $S($D(GMRCSTCK):GMRCSTCK,1:"")
;
STCK(RES) ;change code to status
N CODE
; al:All Status's;dc:Discont.;c:Completed;h:On Hold;f:Flagged;p:Pending;a:Active;e:Expired;s:Scheduled
;;pr:Incomplete;d:Delayed;u:Unreleased;dce:Discont/Ed;x:Cancelled;l:Lapsed;rn:Renewed;':No Status")
CASE ;
I RES="al" S GMRCSTCK="COM,PEN,ACT,SCH,INC,DSC,CAN" Q ;All Status's
; display no. file name file abbr.
I RES="ap" D Q
.F CODE="PEN","ACT","SCH","INC" D CKCODE(CODE) ; All Pending Statuses
I RES="dc" D CKCODE("DSC") Q ; Discont. 1 DISCONTINUED dc
I RES="c" D CKCODE("COM") Q ; Completed 2 COMPLETE c
I RES="p" D CKCODE("PEN") Q ; Pending 5 PENDING p
I RES="a" D CKCODE("ACT") Q ; Active 6 ACTIVE a
I RES="s" D CKCODE("SCH") Q ; Scheduled 8 SCHEDULED s
I RES="pr" D CKCODE("INC") Q ; Incomplete 9 PARTIAL RESULTS pr
I RES="x" D CKCODE("CAN") Q ; Cancelled 13 CANCELLED x
ENDCASE Q
;
CKCODE(CODE) ;
I $D(GMRCSTCK),$$FND(CODE) W $C(7),!,"Already selected" Q
;I +$G(GMRCSTCK) S GMRCSTCK=GMRCSTCK_","_CODE
;I $G(GMRCSTCK) S GMRCSTCK=GMRCSTCK_","_CODE
I $D(GMRCSTCK) S GMRCSTCK=GMRCSTCK_","_CODE
E 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
;
NUMBER ;
I GMRCCTRL'=120 S GMRCCTRL=120
E S GMRCCTRL=0
Q
;
SUMARY ;
;;ACTERAP;Active, By Admin;Active, Edit Re-submit Admin Purpose
;;ACTERCC;Active, Can By Clinic;Active, Edit Re-submit, Cancel by Clinic
;;ACTERCP;Active, Can By Patient;Active, Edit Re-submit, Cancel by Patient
;;ACTERNS;Active, No-Show;Active, Edit Re-submit, No Show
;;ACTEROW;Active, Edit Resubmit;Active, Edit Re-submit, Old Way
;;ACTWOLHNWL;Active, Manually;Active, Without Link History
;;ACTWOLHWL;Active, EWL;Active, Without Link History
;;ACTWOLHIFC;Active, IFC;Active, Without Link History
;;CANCELED;Cancelled;Cancelled
;;COMPLETE;Completed;Completed
;;DSCNTUED;Discontinued;Discontinued
;;INCMPLTE;Incomplete;Incomplete
;;PENNWL;Pending;Pending
;;PENWL;Pending, EWL;Pending, Electronic Wait List
;;SCHWALCO;Sch, Linked, Ck'd Out;Scheduled, Linked, Checked Out;1
;;SCHWALNCO;Scheduled, Linked;Scheduled, Linked;1
;;SCHWHNAL;Sch, Not Linked now;Scheduled, Not Linked
;;SCHWOLHNWL;Sch, Never Linked;Scheduled, Without Link History
;;SCHWOLHWL;Schedule, EWL;Scheduled, Without Link history, wait listed
;;SCHWOLHIFC;Schedule, IFC;Scheduled, Without Link history, interfacility consult
;;TOC;Total Open Consults;Total Open Consults
;;TCC;Total Closed Consults;Total Closed Consults
;;
CT3 ;print clinic summary
D WAIT^DICD K ^TMP("GMRCR",$J)
S LN=0,A="" F S A=$O(^TMP($J,"B",A)) Q:A="" D
.K SUM S HDR="",B="" F S B=$O(^TMP($J,"B",A,B)) Q:B="" D:GMRCSTAT[$E(B,1,3)
..I $D(HDR) D HEADER K HDR
..S SUM(B)=^TMP($J,"B",A,B)
..S CNSDT=0 F S CNSDT=$O(^TMP($J,"B",A,B,CNSDT)) Q:'+CNSDT S CNSLT=0 F S CNSLT=$O(^TMP($J,"B",A,B,CNSDT,CNSLT)) Q:'+CNSLT S CNSLTND=^(CNSLT),PTNM=$P(CNSLTND,U),PRTCNDT=$E(CNSDT,4,5)_"-"_$E(CNSDT,6,7)_"-"_$E(CNSDT,2,3) D
...F TX=1:1 S TEXT=$T(SUMARY+TX),P3=$P(TEXT,";",3) Q:P3="" I P3[B S P4=$P(TEXT,";",4),P6=$P(TEXT,";",6) D
....I P6=1 I $D(^SC("AWAS1",CNSLT)) D
.....S CLINIC=$O(^SC("AWAS1",CNSLT,":"),-1),SDAPT=$O(^SC("AWAS1",CNSLT,CLINIC,":"),-1),STCOD=$P(^SC(CLINIC,0),U,7),STCOD=$P(^DIC(40.7,STCOD,0),U,2),CLINIC=$P(^SC(CLINIC,0),U),SDAPT1=$E(SDAPT,4,5)_"-"_$E(SDAPT,6,7)_"-"_$E(SDAPT,2,3)
.....S Y=SDAPT D DD^%DT S SDAPTIM=$E($P(Y,"@",2),1,5)
....S SETNOD=$$SPC(P4,22),SETNOD=SETNOD_PRTCNDT,SETNOD=$$SPC(SETNOD,32),SETNOD=SETNOD_$P(CNSLTND,U,10),SETNOD=$$SPC(SETNOD,37),SETNOD=SETNOD_$P(CNSLTND,U,9),SETNOD=$$SPC(SETNOD,42),SETNOD=SETNOD_$E(PTNM,1,18),SETNOD=$$SPC(SETNOD,63)
....D:P6=1 D SETNOD
.....S SETNOD=SETNOD_$E(CLINIC,1,15),SETNOD=$$SPC(SETNOD,80),SETNOD=SETNOD_SDAPT1_" @ "_SDAPTIM,SETNOD=$$SPC(SETNOD,98),SETNOD=SETNOD_$E(STCOD,1,5)
.I $D(SUM) S SETNOD=" " D SETNOD D S SETNOD=" " D SETNOD S SETNOD=" " D SETNOD
..S I="" F S I=$O(SUM(I)) Q:I="" F II=1:1 S SM=$T(SUMARY+II) S PC3=$P(SM,";",3) Q:PC3="" I I=PC3 S SETNOD=$$SPC(" ",6),SETNOD=SETNOD_$$SPC(SUM(I),6),SETNOD=SETNOD_$P(SM,";",4) D SETNOD Q
Q
S SETNOD=A_" "_FR_" - "_TO D SETNOD S SETNOD=$$SPC(" ",22),SETNOD=SETNOD_"Consult",SETNOD=$$SPC(SETNOD,63),SETNOD=SETNOD_"Clinic",SETNOD=$$SPC(SETNOD,80),SETNOD=SETNOD_"Appointment",SETNOD=$$SPC(SETNOD,97),SETNOD=SETNOD_"Stop" D SETNOD
S SETNOD=$$SPC("Status",22),SETNOD=SETNOD_"Date",SETNOD=$$SPC(SETNOD,32),SETNOD=SETNOD_"SC",SETNOD=$$SPC(SETNOD,37),SETNOD=SETNOD_"L4",SETNOD=$$SPC(SETNOD,42),SETNOD=SETNOD_"Patient",SETNOD=$$SPC(SETNOD,63)
S SETNOD=SETNOD_"Appointment",SETNOD=$$SPC(SETNOD,80),SETNOD=SETNOD_"Date/time",SETNOD=$$SPC(SETNOD,97),SETNOD=SETNOD_"Code" D SETNOD S SETNOD=DSH D SETNOD
Q
SETNOD ;
S LN=LN+1,^TMP("GMRCR",$J,"CP",LN,0)=SETNOD,SPC="",VALMCNT=LN
Q
SPC(DATA,COL) ;
N SPC S SPC=DATA,L2=COL,L1=$L(DATA) F L3=1:1:(L2-L1) S SPC=SPC_" "
Q SPC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCONS3 5997 printed Sep 23, 2025@19:22:26 Page 2
GMRCONS3 ;ALB/MRY - Consult Status link report ;4/10/06 14:21
+1 ;;3.0;CONSULT/REQUEST TRACKING;**52**;DEC 27, 1997
NEWSTS ;
+1 NEW TEMPSTAT
+2 SET TEMPSTAT=GMRCSTAT
+3 SET GMRCSTAT=$$STS
if GMRCSTAT=""
QUIT
+4 ;S:$D(GMRCQUT) GMRCSTAT=TEMPSTAT
+5 DO CT3
+6 QUIT
STS() ;Select a set of status for view.
+1 IF $DATA(IOTM)
IF $DATA(IOBM)
IF $DATA(IOSTBM)
DO FULL^VALM1
+2 NEW DIR,X,Y,GMRCSTCK
STSAGAIN ;Loop to get another status.
+1 SET DIR(0)="SAOM^al:All Status's;ap:All Pending;dc:Discont.;c:Completed;p:Pending;a:Active;s:Scheduled;pr:Incomplete;x:Cancelled"
+2 SET DIR("A")="Only Display Consults With Status of: "
+3 SET DIR("B")="All Status's"
+4 IF $DATA(GMRCSTCK)
Begin DoDot:1
+5 SET DIR("A")="Another Status to display: "
+6 KILL DIR("B")
End DoDot:1
+7 DO ^DIR
+8 IF $DATA(DUOUT)!($DATA(DTOUT))
SET GMRCQUT=1
GOTO END
+9 IF '$LENGTH(Y)
GOTO END
+10 DO STCK($$LOW^XLFSTR(Y))
+11 IF $DATA(GMRCSTCK)
IF GMRCSTCK'="COM,PEN,ACT,SCH,INC,DSC,CAN"
GOTO STSAGAIN
END QUIT $SELECT($DATA(GMRCSTCK):GMRCSTCK,1:"")
+1 ;
STCK(RES) ;change code to status
+1 NEW CODE
+2 ; al:All Status's;dc:Discont.;c:Completed;h:On Hold;f:Flagged;p:Pending;a:Active;e:Expired;s:Scheduled
+3 ;;pr:Incomplete;d:Delayed;u:Unreleased;dce:Discont/Ed;x:Cancelled;l:Lapsed;rn:Renewed;':No Status")
CASE ;
+1 ;All Status's
IF RES="al"
SET GMRCSTCK="COM,PEN,ACT,SCH,INC,DSC,CAN"
QUIT
+2 ; display no. file name file abbr.
+3 IF RES="ap"
Begin DoDot:1
+4 ; All Pending Statuses
FOR CODE="PEN","ACT","SCH","INC"
DO CKCODE(CODE)
End DoDot:1
QUIT
+5 ; Discont. 1 DISCONTINUED dc
IF RES="dc"
DO CKCODE("DSC")
QUIT
+6 ; Completed 2 COMPLETE c
IF RES="c"
DO CKCODE("COM")
QUIT
+7 ; Pending 5 PENDING p
IF RES="p"
DO CKCODE("PEN")
QUIT
+8 ; Active 6 ACTIVE a
IF RES="a"
DO CKCODE("ACT")
QUIT
+9 ; Scheduled 8 SCHEDULED s
IF RES="s"
DO CKCODE("SCH")
QUIT
+10 ; Incomplete 9 PARTIAL RESULTS pr
IF RES="pr"
DO CKCODE("INC")
QUIT
+11 ; Cancelled 13 CANCELLED x
IF RES="x"
DO CKCODE("CAN")
QUIT
ENDCASE QUIT
+1 ;
CKCODE(CODE) ;
+1 IF $DATA(GMRCSTCK)
IF $$FND(CODE)
WRITE $CHAR(7),!,"Already selected"
QUIT
+2 ;I +$G(GMRCSTCK) S GMRCSTCK=GMRCSTCK_","_CODE
+3 ;I $G(GMRCSTCK) S GMRCSTCK=GMRCSTCK_","_CODE
+4 IF $DATA(GMRCSTCK)
SET GMRCSTCK=GMRCSTCK_","_CODE
+5 IF '$TEST
SET GMRCSTCK=CODE
+6 QUIT
+7 ;
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
+5 ;
NUMBER ;
+1 IF GMRCCTRL'=120
SET GMRCCTRL=120
+2 IF '$TEST
SET GMRCCTRL=0
+3 QUIT
+4 ;
SUMARY ;
+1 ;;ACTERAP;Active, By Admin;Active, Edit Re-submit Admin Purpose
+2 ;;ACTERCC;Active, Can By Clinic;Active, Edit Re-submit, Cancel by Clinic
+3 ;;ACTERCP;Active, Can By Patient;Active, Edit Re-submit, Cancel by Patient
+4 ;;ACTERNS;Active, No-Show;Active, Edit Re-submit, No Show
+5 ;;ACTEROW;Active, Edit Resubmit;Active, Edit Re-submit, Old Way
+6 ;;ACTWOLHNWL;Active, Manually;Active, Without Link History
+7 ;;ACTWOLHWL;Active, EWL;Active, Without Link History
+8 ;;ACTWOLHIFC;Active, IFC;Active, Without Link History
+9 ;;CANCELED;Cancelled;Cancelled
+10 ;;COMPLETE;Completed;Completed
+11 ;;DSCNTUED;Discontinued;Discontinued
+12 ;;INCMPLTE;Incomplete;Incomplete
+13 ;;PENNWL;Pending;Pending
+14 ;;PENWL;Pending, EWL;Pending, Electronic Wait List
+15 ;;SCHWALCO;Sch, Linked, Ck'd Out;Scheduled, Linked, Checked Out;1
+16 ;;SCHWALNCO;Scheduled, Linked;Scheduled, Linked;1
+17 ;;SCHWHNAL;Sch, Not Linked now;Scheduled, Not Linked
+18 ;;SCHWOLHNWL;Sch, Never Linked;Scheduled, Without Link History
+19 ;;SCHWOLHWL;Schedule, EWL;Scheduled, Without Link history, wait listed
+20 ;;SCHWOLHIFC;Schedule, IFC;Scheduled, Without Link history, interfacility consult
+21 ;;TOC;Total Open Consults;Total Open Consults
+22 ;;TCC;Total Closed Consults;Total Closed Consults
+23 ;;
CT3 ;print clinic summary
+1 DO WAIT^DICD
KILL ^TMP("GMRCR",$JOB)
+2 SET LN=0
SET A=""
FOR
SET A=$ORDER(^TMP($JOB,"B",A))
if A=""
QUIT
Begin DoDot:1
+3 KILL SUM
SET HDR=""
SET B=""
FOR
SET B=$ORDER(^TMP($JOB,"B",A,B))
if B=""
QUIT
if GMRCSTAT[$EXTRACT(B,1,3)
Begin DoDot:2
+4 IF $DATA(HDR)
DO HEADER
KILL HDR
+5 SET SUM(B)=^TMP($JOB,"B",A,B)
+6 SET CNSDT=0
FOR
SET CNSDT=$ORDER(^TMP($JOB,"B",A,B,CNSDT))
if '+CNSDT
QUIT
SET CNSLT=0
FOR
SET CNSLT=$ORDER(^TMP($JOB,"B",A,B,CNSDT,CNSLT))
if '+CNSLT
QUIT
SET CNSLTND=^(CNSLT)
SET PTNM=$PIECE(CNSLTND,U)
SET PRTCNDT=$EXTRACT(CNSDT,4,5)_"-"_$EXTRACT(CNSDT,6,7)_"-"_$EXTRACT(CNSDT,2,3)
Begin DoDot:3
+7 FOR TX=1:1
SET TEXT=$TEXT(SUMARY+TX)
SET P3=$PIECE(TEXT,";",3)
if P3=""
QUIT
IF P3[B
SET P4=$PIECE(TEXT,";",4)
SET P6=$PIECE(TEXT,";",6)
Begin DoDot:4
+8 IF P6=1
IF $DATA(^SC("AWAS1",CNSLT))
Begin DoDot:5
+9 SET CLINIC=$ORDER(^SC("AWAS1",CNSLT,":"),-1)
SET SDAPT=$ORDER(^SC("AWAS1",CNSLT,CLINIC,":"),-1)
SET STCOD=$PIECE(^SC(CLINIC,0),U,7)
SET STCOD=$PIECE(^DIC(40.7,STCOD,0),U,2)
SET CLINIC=$PIECE(^SC(CLINIC,0),U)
SET SDAPT1=$EXTRACT(SDAPT,4,5)_"-"_$EXTRACT(SDAPT,6,7)_"-"_$EXTRACT(SDAPT,2,3)
+10 SET Y=SDAPT
DO DD^%DT
SET SDAPTIM=$EXTRACT($PIECE(Y,"@",2),1,5)
End DoDot:5
+11 SET SETNOD=$$SPC(P4,22)
SET SETNOD=SETNOD_PRTCNDT
SET SETNOD=$$SPC(SETNOD,32)
SET SETNOD=SETNOD_$PIECE(CNSLTND,U,10)
SET SETNOD=$$SPC(SETNOD,37)
SET SETNOD=SETNOD_$PIECE(CNSLTND,U,9)
SET SETNOD=$$SPC(SETNOD,42)
SET SETNOD=SETNOD_$EXTRACT(PTNM,1,18)
SET SETNOD=$$SPC(SETNOD,63)
+12 if P6=1
Begin DoDot:5
+13 SET SETNOD=SETNOD_$EXTRACT(CLINIC,1,15)
SET SETNOD=$$SPC(SETNOD,80)
SET SETNOD=SETNOD_SDAPT1_" @ "_SDAPTIM
SET SETNOD=$$SPC(SETNOD,98)
SET SETNOD=SETNOD_$EXTRACT(STCOD,1,5)
End DoDot:5
DO SETNOD
End DoDot:4
End DoDot:3
End DoDot:2
+14 IF $DATA(SUM)
SET SETNOD=" "
DO SETNOD
Begin DoDot:2
+15 SET I=""
FOR
SET I=$ORDER(SUM(I))
if I=""
QUIT
FOR II=1:1
SET SM=$TEXT(SUMARY+II)
SET PC3=$PIECE(SM,";",3)
if PC3=""
QUIT
IF I=PC3
SET SETNOD=$$SPC(" ",6)
SET SETNOD=SETNOD_$$SPC(SUM(I),6)
SET SETNOD=SETNOD_$PIECE(SM,";",4)
DO SETNOD
QUIT
End DoDot:2
SET SETNOD=" "
DO SETNOD
SET SETNOD=" "
DO SETNOD
End DoDot:1
+16 QUIT
+1 SET SETNOD=A_" "_FR_" - "_TO
DO SETNOD
SET SETNOD=$$SPC(" ",22)
SET SETNOD=SETNOD_"Consult"
SET SETNOD=$$SPC(SETNOD,63)
SET SETNOD=SETNOD_"Clinic"
SET SETNOD=$$SPC(SETNOD,80)
SET SETNOD=SETNOD_"Appointment"
SET SETNOD=$$SPC(SETNOD,97)
SET SETNOD=SETNOD_"Stop"
DO SETNOD
+2 SET SETNOD=$$SPC("Status",22)
SET SETNOD=SETNOD_"Date"
SET SETNOD=$$SPC(SETNOD,32)
SET SETNOD=SETNOD_"SC"
SET SETNOD=$$SPC(SETNOD,37)
SET SETNOD=SETNOD_"L4"
SET SETNOD=$$SPC(SETNOD,42)
SET SETNOD=SETNOD_"Patient"
SET SETNOD=$$SPC(SETNOD,63)
+3 SET SETNOD=SETNOD_"Appointment"
SET SETNOD=$$SPC(SETNOD,80)
SET SETNOD=SETNOD_"Date/time"
SET SETNOD=$$SPC(SETNOD,97)
SET SETNOD=SETNOD_"Code"
DO SETNOD
SET SETNOD=DSH
DO SETNOD
+4 QUIT
SETNOD ;
+1 SET LN=LN+1
SET ^TMP("GMRCR",$JOB,"CP",LN,0)=SETNOD
SET SPC=""
SET VALMCNT=LN
+2 QUIT
SPC(DATA,COL) ;
+1 NEW SPC
SET SPC=DATA
SET L2=COL
SET L1=$LENGTH(DATA)
FOR L3=1:1:(L2-L1)
SET SPC=SPC_" "
+2 QUIT SPC
+3 QUIT
