SDECIDX ;ALB/SAT,WTC - VISTA SCHEDULING RPCS ;Feb 12, 2020@15:22
;;5.3;Scheduling;**627,642,658,665,694,784**;Aug 13, 1993;Build 8
;
; The following entry point causes the ^XTMP("SDEC","IDX" global
; to be rebuilt based on the scheduling of the SDEC BUILD IDX option.
ENTRY ; When executed, the following actions will occur:
; - purge existing ^XTMP("SDEC","IDX" data
; - Loop through files 123, 403.5, 409.3, and 409.85 and placing content
; into the XTMP global for retrieval by the SDECIDX GET RPC call.
;
D PURGE
D BUILD
Q
;
PURGE ;EP- Delete the content of the global and set zero node
;
K ^XTMP("SDEC","IDX")
S ^XTMP("SDEC",0)=$$FMADD^XLFDT(DT,7)_U_$$DT^XLFDT
Q
;
BUILD ;EP- Generate content
;
N FILE,CNT,DLM,SDMAX
S SDMAX=$$GET1^DIQ(409.98,1_",",5) ;784
S:'(+SDMAX) SDMAX=200 ;784
S CNT=0 ;alb/sat 658
S DLM="|"
F LP=123,403.5,409.3,409.85 D
.D BLD(LP)
D SETNODEC(CNT)
Q
;
BLD(FIL) ;EP-
I FIL=123 D Q
.D BLD123
E I FIL=403.5 D Q
.D BLD4035
E I FIL=409.3 D Q
.D BLD4093
E I FIL=409.85 D Q
.D BLD40985
Q
;
BLD123 ;EP- REQUEST/CONSULTATION (C)
Q:'$$TEST("REQGET^SDEC51")
;Key stored in 4Oth piece
;SVCCONN - 27th piece
;SVCCONNP - 28th piece
;WLSVCCON - no value use ""
;Desired DATE - no value use 0
;Origination Date - ORIGDT - 2nd piece
;Priority Group (PRIGRP header)- 24th piece
N LP,NOD,NODRMG,GBL,SDSUB,SVCP
N SDECY,SDECY1,SDBEG,SDEND,MAXREC,LASTSUB,SORTSTR
S GBL="~GMR(123,"
D RMG^SDECRMG(.SDECY,9999999,,"REQUESTTYPE^C|WAITTIME^>=90|ALL^C",,,SDMAX) ;784 changed 200 to SDMAX
S LP=0 F S LP=$O(@SDECY@(LP)) Q:LP'>0 D
.S NODRMG=@SDECY@(LP)
.D REQGET^SDEC(.SDECY1,,,,,$P(NODRMG,U,2))
.D SETNODEP(GBL,$G(@SDECY1@(0)))
.S NOD=@SDECY1@(1)
.S SORTSTR=$P(NODRMG,U,3)
.D SETNODE(SORTSTR,GBL_DLM_$$PC(NOD,1)_DLM_"C",NOD,40)
.I $P(NOD,U,8)'="" D
..K SDSUB
..S SDSUB($P(NOD,U,8))=""
..D SETXREF("C","E",.SDSUB,$P(NOD,U,1))
.K @SDECY1
K @SDECY
Q
BLD4035 ;EP- RECALL REMINDERS (R)
Q:'$$TEST("RECGET^SDEC52")
;Key stored in 42nd piece
;SVCCONN - 28th piece
;SVCCONNP - 29th piece
;WLSVCCON - no value use ""
;Desired DATE - 19th piece - External format
;Origination Date - ORIGDT - 32nd piece
;Priority Group (PRIGRP header)- 25th piece
N LP,NOD,NODRMG,GBL,SVCP,SORTSTR
N SDECY,SDECY1,DFN,SDBEG,SDEND,MAXREC,LASTSUB
S GBL="~SD(403.5,"
D RMG^SDECRMG(.SDECY,9999999,,"REQUESTTYPE^R|WAITTIME^>=90",,,SDMAX) ;784 changed 200 to SDMAX
S LP=0 F S LP=$O(@SDECY@(LP)) Q:LP'>0 D
.S NODRMG=@SDECY@(LP)
.D RECGET^SDEC(.SDECY1,,,,,,$P(NODRMG,U,2))
.D SETNODEP(GBL,@SDECY1@(0))
.S NOD=@SDECY1@(1)
.S SORTSTR=$P(NODRMG,U,3)
.D SETNODE(SORTSTR,GBL_DLM_$$PC(NOD,1)_DLM_"R",NOD,42)
.K @SDECY1
K @SDECY
Q
BLD4093 ;EP- SD WAIT LIST (E)
Q:'$$TEST("WLGET^SDECWL1")
;Key stored in 56th piece
;SVCCONN - 36th piece
;SVCCONNP - 37th piece
;Desired DATE - 24th piece
;Origination Date - ORIGDT - 8th piece
;Enrollment Priority Group (PRIGRP header) - 33rd piece
;WLSVCCON - 44th piece
N LP,NOD,NODRMG,GBL,SCPRI,SVCP
N SDECY,SDECY1,MAXREC,SDBEG,SDEND,DFN,LASTSUB,SORTSTR
S GBL="~SDWL(409.3,"
D RMG^SDECRMG(.SDECY,9999999,,"REQUESTTYPE^E|WAITTIME^>=90",,,SDMAX) ;784 changed 200 to SDMAX
S LP=0 F S LP=$O(@SDECY@(LP)) Q:LP'>0 D
.S NODRMG=@SDECY@(LP)
.D WLGET^SDEC(.SDECY1,$P(NODRMG,U,2))
.D SETNODEP(GBL,$G(@SDECY1@(0)))
.S NOD=@SDECY1@(1)
.S SORTSTR=$P(NODRMG,U,3)
.D SETNODE(SORTSTR,GBL_DLM_$$PC(NOD,7)_DLM_"E",NOD,56)
.K @SDECY1
K @SDECY
Q
BLD40985 ;EP- SDEC APPT REQUEST (A)
Q:'$$TEST("ARGET^SDECAR1")
;Key stored in 56th piece
;SVCCONN - 29th piece
;SVCCONNP - 30th piece
;Desired DATE - 20th piece
;Origination Date - ORIGDT - 8th piece
;Priority Group (PRIGRP header) - 26th piece
;WLSVCCON = 37th piece
N LP,NOD,NODRMG,GBL,SVCP,SORTSTR
N SDECY,SDECY1,DFN,MAXREC,LASTSUB,ARIEN1,SDBEG,SDEND
S GBL="~SDEC(409.85,"
D RMG^SDECRMG(.SDECY,9999999,,"REQUESTTYPE^A|WAITTIME^>=90",,,SDMAX) ;784 changed 200 to SDMAX
S LP=0 F S LP=$O(@SDECY@(LP)) Q:LP'>0 D
.S NODRMG=@SDECY@(LP)
.D ARGET^SDEC(.SDECY1,$P(NODRMG,U,2))
.D SETNODEP(GBL,$G(@SDECY1@(0)))
.S NOD=@SDECY1@(1)
.S SORTSTR=$P(NODRMG,U,3)
.D SETNODE(SORTSTR,GBL_DLM_$$PC(NOD,7)_DLM_"A",NOD,56)
.K @SDECY1
K @SDECY
Q
;
SETNODE(S1,S3,VAL,KEYP) ;EP-
; S1 - Sort String
; S2 - not used
; S3 - GBL | IEN | <request type> ACER
; VAL -
; KEYP -
Q:'$L($D(S1))!'$L($D(S3))
N KEY
S KEY=S1_DLM_S3
S CNT=$G(CNT)+1
S VAL=$P(VAL,$C(30))
S:$G(KEYP) $P(VAL,U,KEYP)=KEY
S ^XTMP("SDEC","IDX","XREF1",S1,0,S3)=CNT
S ^XTMP("SDEC","IDX","DATA",CNT)=$G(VAL)
S ^XTMP("SDEC","IDX","XREF2",KEY)=CNT
Q
;
SETXREF(S4,S5,DX,DA,VAL) ;request type specific xref for 1 entry
; S4 = request type A C E or R
; S5 = xref subscript
; .DX = array of subscripts
; DA = pointer to request type
; VAL = value to set xref to; default to ""
N SDI,SDSUB
S VAL=$G(VAL)
S SDSUB=""
S SDI="" F S SDI=$O(DX(SDI)) Q:SDI="" D
.S SDSUB=$S(SDSUB'="":SDSUB_",",1:"")_SDI
S ^XTMP("SDEC","IDX","XREF"_S4,S5,SDSUB,DA)=VAL
Q
;
SETNODEC(CNT) ;EP-
S ^XTMP("SDEC","IDX","COUNT")=$G(CNT)
Q
;
SETNODEP(GBL,VAL) ;EP-
Q:'$L($D(GBL))
S ^XTMP("SDEC","IDX","PATTERNS",GBL)=$P($G(VAL),$C(30))
Q
;
PC(VAL,PIECE,DLM) ;EP-
S DLM=$G(DLM,U)
Q $P($G(VAL),DLM,+$G(PIECE))
;
; Test for tag/routine
TEST(X) ;EP
N Z
S:X[U Z=$P(X,U),X=$P(X,U,2)
Q:'$L(X)!(X'?.1"%"1.AN) 0
X ^%ZOSF("TEST")
Q $S('$T:0,$G(Z)="":1,Z'?.1"%"1.AN:0,1:$T(@Z^@X)'="")
;
; The GETREC entry point is called by the SDECIDX GETREC RPC.
; Input: LASTREC - (optional) holds the key to the last call and when passed
; the next bolus of data will start with the
; following record.
; MAXREC - (optional) returns 25 records by default
; STYLE - (optional) (D)ata (default) or (R)ecord pointer.
; (D)ata returns data in the format specific to the file
; (R)ecord returns the Type^IEN of the Type file
;
GETREC(DATA,LASTREC,MAXREC,STYLE) ;EP-
N LP,REC,IDX,CNT,DLM
S DLM="|"
S DATA=$$TMPGBL
S LASTREC=$G(LASTREC,"")
S MAXREC=$G(MAXREC,25)
S STYLE=$G(STYLE,"D")
S CNT=0
I STYLE="D" D
.S LP=LASTREC F S LP=$O(^XTMP("SDEC","IDX","XREF2",LP)) Q:LP="" D Q:((CNT\2)=MAXREC)
..S REC=^(LP)
..I $$PC(LP,8,DLM)="R",'$D(^SD(403.5,$$PC(LP,7,DLM),0)) Q ;record has been moved to RECALL REMINDERS REMOVED
..I $$PC(LP,8,DLM)="C",$$REQCHK^SDEC51("",$$PC(LP,7,DLM)) Q ;record has an activity scheduled or has been cancelled
..I $$PC(LP,8,DLM)="E",$$GET1^DIQ(409.3,$$PC(LP,7,DLM),23,"I")="C" Q ;alb/sat 665 - record is closed
..I $$PC(LP,8,DLM)="A",$$GET1^DIQ(409.85,$$PC(LP,7,DLM),23,"I")="C" Q ;alb/sat 665 - record is closed
..S REC=$P(^XTMP("SDEC","IDX","DATA",REC),$C(30))
..S CNT=CNT+1
..S @DATA@(CNT)=$G(^XTMP("SDEC","IDX","PATTERNS",$P(LP,DLM,6)))_$C(30)
..S CNT=CNT+1
..S @DATA@(CNT)=REC_$C(30)
E I STYLE="R" D
. ;
. ; Set up to filter out VETERAN requests if user does not have the key. wtc/mbs 694 7/24/2018
. ;
. N VAOSUSR ;
. D OWNSKEY^XUSRB(.VAOSUSR,"SDECZ REQUEST") ;
. ;
.S @DATA@(0)="T00030TYPE^T00030IEN^T00030KEY"_$C(30)
.S LP=LASTREC F S LP=$O(^XTMP("SDEC","IDX","XREF2",LP)) Q:LP="" D Q:(CNT=MAXREC)
..I $$PC(LP,8,DLM)="R",'$D(^SD(403.5,$$PC(LP,7,DLM),0)) Q ;record has been moved to RECALL REMINDERS REMOVED
..I $$PC(LP,8,DLM)="C",$$REQCHK^SDEC51("",$$PC(LP,7,DLM)) Q ;record has an activity scheduled or has been cancelled
..I $$PC(LP,8,DLM)="E",$$GET1^DIQ(409.3,$$PC(LP,7,DLM),23,"I")="C" Q ;alb/sat 665 - record is closed
..I $$PC(LP,8,DLM)="A",$$GET1^DIQ(409.85,$$PC(LP,7,DLM),23,"I")="C" Q ;alb/sat 665 - record is closed
.. ;
.. ; Exclude VETERAN requests if user does not have the key. wtc/mbs 694 7/24/2018
.. ;
.. I $$PC(LP,8,DLM)="A",$$GET1^DIQ(409.85,$$PC(LP,7,DLM),4,"I")="VETERAN",'$G(VAOSUSR(0)) Q ;MBS - vaos record and user doesn't have key
.. ;
..S CNT=CNT+1
..S @DATA@(CNT)=$$PC(LP,8,DLM)_U_$$PC(LP,7,DLM)_U_LP_$C(30)
S @DATA@(CNT)=$P(@DATA@(CNT),$C(30))_$C(30,31)
Q
;
TMPGBL() ;EP-
K ^TMP("SDECIDX",$J) Q $NA(^($J))
; Convert external dates to FileMan format
CVTDT(VAL) ;EP-
D DT^DILF(,VAL,.VAL)
Q VAL
; Returns inverse date value
INVDT(VAL) ;EP-
Q:(VAL<1) VAL
Q (9999999.9999-VAL)
RECCNT(DATA) ;EP-
S DATA=+$G(^XTMP("SDEC","IDX","COUNT"))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDECIDX 8533 printed Dec 13, 2024@02:52:11 Page 2
SDECIDX ;ALB/SAT,WTC - VISTA SCHEDULING RPCS ;Feb 12, 2020@15:22
+1 ;;5.3;Scheduling;**627,642,658,665,694,784**;Aug 13, 1993;Build 8
+2 ;
+3 ; The following entry point causes the ^XTMP("SDEC","IDX" global
+4 ; to be rebuilt based on the scheduling of the SDEC BUILD IDX option.
ENTRY ; When executed, the following actions will occur:
+1 ; - purge existing ^XTMP("SDEC","IDX" data
+2 ; - Loop through files 123, 403.5, 409.3, and 409.85 and placing content
+3 ; into the XTMP global for retrieval by the SDECIDX GET RPC call.
+4 ;
+5 DO PURGE
+6 DO BUILD
+7 QUIT
+8 ;
PURGE ;EP- Delete the content of the global and set zero node
+1 ;
+2 KILL ^XTMP("SDEC","IDX")
+3 SET ^XTMP("SDEC",0)=$$FMADD^XLFDT(DT,7)_U_$$DT^XLFDT
+4 QUIT
+5 ;
BUILD ;EP- Generate content
+1 ;
+2 NEW FILE,CNT,DLM,SDMAX
+3 ;784
SET SDMAX=$$GET1^DIQ(409.98,1_",",5)
+4 ;784
if '(+SDMAX)
SET SDMAX=200
+5 ;alb/sat 658
SET CNT=0
+6 SET DLM="|"
+7 FOR LP=123,403.5,409.3,409.85
Begin DoDot:1
+8 DO BLD(LP)
End DoDot:1
+9 DO SETNODEC(CNT)
+10 QUIT
+11 ;
BLD(FIL) ;EP-
+1 IF FIL=123
Begin DoDot:1
+2 DO BLD123
End DoDot:1
QUIT
+3 IF '$TEST
IF FIL=403.5
Begin DoDot:1
+4 DO BLD4035
End DoDot:1
QUIT
+5 IF '$TEST
IF FIL=409.3
Begin DoDot:1
+6 DO BLD4093
End DoDot:1
QUIT
+7 IF '$TEST
IF FIL=409.85
Begin DoDot:1
+8 DO BLD40985
End DoDot:1
QUIT
+9 QUIT
+10 ;
BLD123 ;EP- REQUEST/CONSULTATION (C)
+1 if '$$TEST("REQGET^SDEC51")
QUIT
+2 ;Key stored in 4Oth piece
+3 ;SVCCONN - 27th piece
+4 ;SVCCONNP - 28th piece
+5 ;WLSVCCON - no value use ""
+6 ;Desired DATE - no value use 0
+7 ;Origination Date - ORIGDT - 2nd piece
+8 ;Priority Group (PRIGRP header)- 24th piece
+9 NEW LP,NOD,NODRMG,GBL,SDSUB,SVCP
+10 NEW SDECY,SDECY1,SDBEG,SDEND,MAXREC,LASTSUB,SORTSTR
+11 SET GBL="~GMR(123,"
+12 ;784 changed 200 to SDMAX
DO RMG^SDECRMG(.SDECY,9999999,,"REQUESTTYPE^C|WAITTIME^>=90|ALL^C",,,SDMAX)
+13 SET LP=0
FOR
SET LP=$ORDER(@SDECY@(LP))
if LP'>0
QUIT
Begin DoDot:1
+14 SET NODRMG=@SDECY@(LP)
+15 DO REQGET^SDEC(.SDECY1,,,,,$PIECE(NODRMG,U,2))
+16 DO SETNODEP(GBL,$GET(@SDECY1@(0)))
+17 SET NOD=@SDECY1@(1)
+18 SET SORTSTR=$PIECE(NODRMG,U,3)
+19 DO SETNODE(SORTSTR,GBL_DLM_$$PC(NOD,1)_DLM_"C",NOD,40)
+20 IF $PIECE(NOD,U,8)'=""
Begin DoDot:2
+21 KILL SDSUB
+22 SET SDSUB($PIECE(NOD,U,8))=""
+23 DO SETXREF("C","E",.SDSUB,$PIECE(NOD,U,1))
End DoDot:2
+24 KILL @SDECY1
End DoDot:1
+25 KILL @SDECY
+26 QUIT
BLD4035 ;EP- RECALL REMINDERS (R)
+1 if '$$TEST("RECGET^SDEC52")
QUIT
+2 ;Key stored in 42nd piece
+3 ;SVCCONN - 28th piece
+4 ;SVCCONNP - 29th piece
+5 ;WLSVCCON - no value use ""
+6 ;Desired DATE - 19th piece - External format
+7 ;Origination Date - ORIGDT - 32nd piece
+8 ;Priority Group (PRIGRP header)- 25th piece
+9 NEW LP,NOD,NODRMG,GBL,SVCP,SORTSTR
+10 NEW SDECY,SDECY1,DFN,SDBEG,SDEND,MAXREC,LASTSUB
+11 SET GBL="~SD(403.5,"
+12 ;784 changed 200 to SDMAX
DO RMG^SDECRMG(.SDECY,9999999,,"REQUESTTYPE^R|WAITTIME^>=90",,,SDMAX)
+13 SET LP=0
FOR
SET LP=$ORDER(@SDECY@(LP))
if LP'>0
QUIT
Begin DoDot:1
+14 SET NODRMG=@SDECY@(LP)
+15 DO RECGET^SDEC(.SDECY1,,,,,,$PIECE(NODRMG,U,2))
+16 DO SETNODEP(GBL,@SDECY1@(0))
+17 SET NOD=@SDECY1@(1)
+18 SET SORTSTR=$PIECE(NODRMG,U,3)
+19 DO SETNODE(SORTSTR,GBL_DLM_$$PC(NOD,1)_DLM_"R",NOD,42)
+20 KILL @SDECY1
End DoDot:1
+21 KILL @SDECY
+22 QUIT
BLD4093 ;EP- SD WAIT LIST (E)
+1 if '$$TEST("WLGET^SDECWL1")
QUIT
+2 ;Key stored in 56th piece
+3 ;SVCCONN - 36th piece
+4 ;SVCCONNP - 37th piece
+5 ;Desired DATE - 24th piece
+6 ;Origination Date - ORIGDT - 8th piece
+7 ;Enrollment Priority Group (PRIGRP header) - 33rd piece
+8 ;WLSVCCON - 44th piece
+9 NEW LP,NOD,NODRMG,GBL,SCPRI,SVCP
+10 NEW SDECY,SDECY1,MAXREC,SDBEG,SDEND,DFN,LASTSUB,SORTSTR
+11 SET GBL="~SDWL(409.3,"
+12 ;784 changed 200 to SDMAX
DO RMG^SDECRMG(.SDECY,9999999,,"REQUESTTYPE^E|WAITTIME^>=90",,,SDMAX)
+13 SET LP=0
FOR
SET LP=$ORDER(@SDECY@(LP))
if LP'>0
QUIT
Begin DoDot:1
+14 SET NODRMG=@SDECY@(LP)
+15 DO WLGET^SDEC(.SDECY1,$PIECE(NODRMG,U,2))
+16 DO SETNODEP(GBL,$GET(@SDECY1@(0)))
+17 SET NOD=@SDECY1@(1)
+18 SET SORTSTR=$PIECE(NODRMG,U,3)
+19 DO SETNODE(SORTSTR,GBL_DLM_$$PC(NOD,7)_DLM_"E",NOD,56)
+20 KILL @SDECY1
End DoDot:1
+21 KILL @SDECY
+22 QUIT
BLD40985 ;EP- SDEC APPT REQUEST (A)
+1 if '$$TEST("ARGET^SDECAR1")
QUIT
+2 ;Key stored in 56th piece
+3 ;SVCCONN - 29th piece
+4 ;SVCCONNP - 30th piece
+5 ;Desired DATE - 20th piece
+6 ;Origination Date - ORIGDT - 8th piece
+7 ;Priority Group (PRIGRP header) - 26th piece
+8 ;WLSVCCON = 37th piece
+9 NEW LP,NOD,NODRMG,GBL,SVCP,SORTSTR
+10 NEW SDECY,SDECY1,DFN,MAXREC,LASTSUB,ARIEN1,SDBEG,SDEND
+11 SET GBL="~SDEC(409.85,"
+12 ;784 changed 200 to SDMAX
DO RMG^SDECRMG(.SDECY,9999999,,"REQUESTTYPE^A|WAITTIME^>=90",,,SDMAX)
+13 SET LP=0
FOR
SET LP=$ORDER(@SDECY@(LP))
if LP'>0
QUIT
Begin DoDot:1
+14 SET NODRMG=@SDECY@(LP)
+15 DO ARGET^SDEC(.SDECY1,$PIECE(NODRMG,U,2))
+16 DO SETNODEP(GBL,$GET(@SDECY1@(0)))
+17 SET NOD=@SDECY1@(1)
+18 SET SORTSTR=$PIECE(NODRMG,U,3)
+19 DO SETNODE(SORTSTR,GBL_DLM_$$PC(NOD,7)_DLM_"A",NOD,56)
+20 KILL @SDECY1
End DoDot:1
+21 KILL @SDECY
+22 QUIT
+23 ;
SETNODE(S1,S3,VAL,KEYP) ;EP-
+1 ; S1 - Sort String
+2 ; S2 - not used
+3 ; S3 - GBL | IEN | <request type> ACER
+4 ; VAL -
+5 ; KEYP -
+6 if '$LENGTH($DATA(S1))!'$LENGTH($DATA(S3))
QUIT
+7 NEW KEY
+8 SET KEY=S1_DLM_S3
+9 SET CNT=$GET(CNT)+1
+10 SET VAL=$PIECE(VAL,$CHAR(30))
+11 if $GET(KEYP)
SET $PIECE(VAL,U,KEYP)=KEY
+12 SET ^XTMP("SDEC","IDX","XREF1",S1,0,S3)=CNT
+13 SET ^XTMP("SDEC","IDX","DATA",CNT)=$GET(VAL)
+14 SET ^XTMP("SDEC","IDX","XREF2",KEY)=CNT
+15 QUIT
+16 ;
SETXREF(S4,S5,DX,DA,VAL) ;request type specific xref for 1 entry
+1 ; S4 = request type A C E or R
+2 ; S5 = xref subscript
+3 ; .DX = array of subscripts
+4 ; DA = pointer to request type
+5 ; VAL = value to set xref to; default to ""
+6 NEW SDI,SDSUB
+7 SET VAL=$GET(VAL)
+8 SET SDSUB=""
+9 SET SDI=""
FOR
SET SDI=$ORDER(DX(SDI))
if SDI=""
QUIT
Begin DoDot:1
+10 SET SDSUB=$SELECT(SDSUB'="":SDSUB_",",1:"")_SDI
End DoDot:1
+11 SET ^XTMP("SDEC","IDX","XREF"_S4,S5,SDSUB,DA)=VAL
+12 QUIT
+13 ;
SETNODEC(CNT) ;EP-
+1 SET ^XTMP("SDEC","IDX","COUNT")=$GET(CNT)
+2 QUIT
+3 ;
SETNODEP(GBL,VAL) ;EP-
+1 if '$LENGTH($DATA(GBL))
QUIT
+2 SET ^XTMP("SDEC","IDX","PATTERNS",GBL)=$PIECE($GET(VAL),$CHAR(30))
+3 QUIT
+4 ;
PC(VAL,PIECE,DLM) ;EP-
+1 SET DLM=$GET(DLM,U)
+2 QUIT $PIECE($GET(VAL),DLM,+$GET(PIECE))
+3 ;
+4 ; Test for tag/routine
TEST(X) ;EP
+1 NEW Z
+2 if X[U
SET Z=$PIECE(X,U)
SET X=$PIECE(X,U,2)
+3 if '$LENGTH(X)!(X'?.1"%"1.AN)
QUIT 0
+4 XECUTE ^%ZOSF("TEST")
+5 QUIT $SELECT('$TEST:0,$GET(Z)="":1,Z'?.1"%"1.AN:0,1:$TEXT(@Z^@X)'="")
+6 ;
+7 ; The GETREC entry point is called by the SDECIDX GETREC RPC.
+8 ; Input: LASTREC - (optional) holds the key to the last call and when passed
+9 ; the next bolus of data will start with the
+10 ; following record.
+11 ; MAXREC - (optional) returns 25 records by default
+12 ; STYLE - (optional) (D)ata (default) or (R)ecord pointer.
+13 ; (D)ata returns data in the format specific to the file
+14 ; (R)ecord returns the Type^IEN of the Type file
+15 ;
GETREC(DATA,LASTREC,MAXREC,STYLE) ;EP-
+1 NEW LP,REC,IDX,CNT,DLM
+2 SET DLM="|"
+3 SET DATA=$$TMPGBL
+4 SET LASTREC=$GET(LASTREC,"")
+5 SET MAXREC=$GET(MAXREC,25)
+6 SET STYLE=$GET(STYLE,"D")
+7 SET CNT=0
+8 IF STYLE="D"
Begin DoDot:1
+9 SET LP=LASTREC
FOR
SET LP=$ORDER(^XTMP("SDEC","IDX","XREF2",LP))
if LP=""
QUIT
Begin DoDot:2
+10 SET REC=^(LP)
+11 ;record has been moved to RECALL REMINDERS REMOVED
IF $$PC(LP,8,DLM)="R"
IF '$DATA(^SD(403.5,$$PC(LP,7,DLM),0))
QUIT
+12 ;record has an activity scheduled or has been cancelled
IF $$PC(LP,8,DLM)="C"
IF $$REQCHK^SDEC51("",$$PC(LP,7,DLM))
QUIT
+13 ;alb/sat 665 - record is closed
IF $$PC(LP,8,DLM)="E"
IF $$GET1^DIQ(409.3,$$PC(LP,7,DLM),23,"I")="C"
QUIT
+14 ;alb/sat 665 - record is closed
IF $$PC(LP,8,DLM)="A"
IF $$GET1^DIQ(409.85,$$PC(LP,7,DLM),23,"I")="C"
QUIT
+15 SET REC=$PIECE(^XTMP("SDEC","IDX","DATA",REC),$CHAR(30))
+16 SET CNT=CNT+1
+17 SET @DATA@(CNT)=$GET(^XTMP("SDEC","IDX","PATTERNS",$PIECE(LP,DLM,6)))_$CHAR(30)
+18 SET CNT=CNT+1
+19 SET @DATA@(CNT)=REC_$CHAR(30)
End DoDot:2
if ((CNT\2)=MAXREC)
QUIT
End DoDot:1
+20 IF '$TEST
IF STYLE="R"
Begin DoDot:1
+21 ;
+22 ; Set up to filter out VETERAN requests if user does not have the key. wtc/mbs 694 7/24/2018
+23 ;
+24 ;
NEW VAOSUSR
+25 ;
DO OWNSKEY^XUSRB(.VAOSUSR,"SDECZ REQUEST")
+26 ;
+27 SET @DATA@(0)="T00030TYPE^T00030IEN^T00030KEY"_$CHAR(30)
+28 SET LP=LASTREC
FOR
SET LP=$ORDER(^XTMP("SDEC","IDX","XREF2",LP))
if LP=""
QUIT
Begin DoDot:2
+29 ;record has been moved to RECALL REMINDERS REMOVED
IF $$PC(LP,8,DLM)="R"
IF '$DATA(^SD(403.5,$$PC(LP,7,DLM),0))
QUIT
+30 ;record has an activity scheduled or has been cancelled
IF $$PC(LP,8,DLM)="C"
IF $$REQCHK^SDEC51("",$$PC(LP,7,DLM))
QUIT
+31 ;alb/sat 665 - record is closed
IF $$PC(LP,8,DLM)="E"
IF $$GET1^DIQ(409.3,$$PC(LP,7,DLM),23,"I")="C"
QUIT
+32 ;alb/sat 665 - record is closed
IF $$PC(LP,8,DLM)="A"
IF $$GET1^DIQ(409.85,$$PC(LP,7,DLM),23,"I")="C"
QUIT
+33 ;
+34 ; Exclude VETERAN requests if user does not have the key. wtc/mbs 694 7/24/2018
+35 ;
+36 ;MBS - vaos record and user doesn't have key
IF $$PC(LP,8,DLM)="A"
IF $$GET1^DIQ(409.85,$$PC(LP,7,DLM),4,"I")="VETERAN"
IF '$GET(VAOSUSR(0))
QUIT
+37 ;
+38 SET CNT=CNT+1
+39 SET @DATA@(CNT)=$$PC(LP,8,DLM)_U_$$PC(LP,7,DLM)_U_LP_$CHAR(30)
End DoDot:2
if (CNT=MAXREC)
QUIT
End DoDot:1
+40 SET @DATA@(CNT)=$PIECE(@DATA@(CNT),$CHAR(30))_$CHAR(30,31)
+41 QUIT
+42 ;
TMPGBL() ;EP-
+1 KILL ^TMP("SDECIDX",$JOB)
QUIT $NAME(^($JOB))
+2 ; Convert external dates to FileMan format
CVTDT(VAL) ;EP-
+1 DO DT^DILF(,VAL,.VAL)
+2 QUIT VAL
+3 ; Returns inverse date value
INVDT(VAL) ;EP-
+1 if (VAL<1)
QUIT VAL
+2 QUIT (9999999.9999-VAL)
RECCNT(DATA) ;EP-
+1 SET DATA=+$GET(^XTMP("SDEC","IDX","COUNT"))
+2 QUIT
