SDECRMG1 ;ALB/SAT/JSM - VISTA SCHEDULING RPCS ;MAR 15, 2017
;;5.3;Scheduling;**627,642,651,658**;Aug 13, 1993;Build 23
;
; The following entry point causes the ^XTMP("SDEC","IDX" global
; to be rebuilt based on the scheduling of the SDEC BUILD IDX option.
WAIT(SDCY,MAXREC,DFN,SDBEG,SDEND,CLINIC,PRI,SCVISIT,SVCR,ORIGDT,DESDT,DESDTR,PRIGRP,SORT,PTS,SDMAX,URG,SDSVC,SDLASTE,ORIGDTR,SDCNT,MGIENS,SDALL) ;EP
;Key stored in 56th piece
;SVCCONNP - 37th piece
;Desired DATE - 24th piece
;Origination Date - ORIGDT - 8th piece
;Priority Group - 33th piece
;IEN in 7th piece
Q:+URG ;only check consults if urgency filter passed in
N %DT,LP,NOD,GBL,DLM,TYP,SDCF,SDI,SVCL,X,Y
N RET,WLIEN1,LASTSUB
S SVCL=""
S SDCF=1
I +CLINIC S SDCF=0 D
.S SDI="" F S SDI=$O(CLINIC(SDI)) Q:SDI="" D Q:SDCF=1
..S:$O(^SDWL(409.32,"B",SDI,0)) SDCF=1
Q:'+SDCF
S SDMAX=$G(SDMAX,50)
S GBL="~SDWL(409.3,"
S DLM="|",TYP="E",LASTSUB=""
S WLIEN1=$G(WLIEN1),MAXREC=$G(MAXREC),SDBEG=$G(SDBEG),SDEND=$G(SDEND),DFN=$G(DFN),CLINIC=$G(CLINIC)
S:SDBEG="" SDBEG=1410102 ;alb/sat 658 use valid FM range instead of 1000101
S:SDEND="" SDEND=$S(DFN'="":4141015,1:$$FMADD^XLFDT($$NOW^XLFDT,-90)) ;alb/sat 658 use valid FM range instead of 9991231
S SCVISIT=$G(SCVISIT)
S SVCR=$G(SVCR)
S SDSVC=$G(SDSVC) I +SDSVC S SVCL=$$SVCL(.SDSVC)
S SDLASTE=$G(SDLASTE)
F D Q:SDLASTE="" Q:SDCNT'<SDMAX
.D WLGET^SDEC(.RET,WLIEN1,SDMAX-SDCNT,SDBEG,SDEND,DFN,SDLASTE,+$D(SORT("B","ETOPD")),SVCL,DESDT,PRI,SVCR,SCVISIT,CLINIC,ORIGDT) ;alb/sat 658 add SVCL...
.S X=$O(@RET@(9999999),-1) S NOD=@RET@(X) S SDLASTE=$P(NOD,U,56)
.I 'X S SDLASTE="" Q
.S LP=0 F S LP=$O(@RET@(LP)) Q:LP="" D Q:SDCNT'<SDMAX
..S NOD=@RET@(LP)
..Q:$D(MGIENS("E"_$P(NOD,U,7)))
..D WAIT1(MAXREC,DFN,SDBEG,SDEND,.CLINIC,.PRI,SCVISIT,SVCR,.ORIGDT,.DESDT,DESDTR,PRIGRP,.SORT,.PTS,SDMAX,.URG,.SDSVC,.SDLASTA,.ORIGDTR,.SDCNT,NOD)
Q
WAIT1(MAXREC,DFN,SDBEG,SDEND,CLINIC,PRI,SCVISIT,SVCR,ORIGDT,DESDT,DESDTR,PRIGRP,SORT,PTS,SDMAX,URG,SDSVC,SDLASTA,ORIGDTR,SDCNT,NOD,MGIENS,SDALL) ;get/check/process 1 entry
N CLGP,DDTE,DESGP,IEN,ODTE,ORIGGP,PGRP,PT,SCPRI,SORTSTR,SVCP,SVCPINV,TYP,WAITD
S TYP="E"
S PGRP=$P(NOD,U,33) ;compare to ENROLLMENT PRIORITY 28 instead of Patient's Priority Group in 33
S PT=$P(NOD,U,1)
I PTS'="",PT'="",$D(PTS(PT))=0 Q ;No match on patients
I PGRP="" S PGRP="GROUP 0"
I PRIGRP=1,$D(PRI(PGRP))=0 Q ;No match on priority group
S CLGP=$P(NOD,U,16) ;I CLGP'="" S CLGP=$$GET1^DIQ(409.32,CLGP_",",.01,"I")
I +CLINIC,CLGP="" Q
I +CLINIC,CLGP'="",$D(CLINIC(CLGP))=0 Q ;match clinic filter
I CLGP'="",$$GET1^DIQ(44,CLGP_",",50.01,"I")=1 Q ;do not return if OOS? is yes
S DESGP=$P(NOD,U,24)
I DESDT'="",DESGP'="",$D(DESDT(DESGP))=0 Q ;match date of request with desired date
I DESDTR'="",DESGP'="",(DESGP<$P(DESDTR,"~",1))!(DESGP>$P(DESDTR,"~",2)) Q ;match date of request with range of desired dates
S ORIGGP=$P(NOD,U,8)
I ORIGDTR'="",ORIGGP'="",(ORIGGP<$P(ORIGDTR,"~",1))!(ORIGGP>$P(ORIGDTR,"~",2)) Q ;match origination date range with file entry date
I ORIGDT'="",ORIGGP'="",$D(ORIGDT(ORIGGP))=0 Q ;match origination date with file entry date
S IEN=$P(NOD,U,7)
S SVCP=$P(NOD,U,37)
S SVCPINV=100-SVCP
I SCVISIT'="",SCVISIT'="BOTH" Q:(SCVISIT="NO")&($P(NOD,U,36)="") Q:SCVISIT'=$P(NOD,U,36) ;SCVisit for filter (patient)
S SCPRI=$P(NOD,U,26)="YES"
S SVCREL=$P(NOD,U,44)="YES" ;SVCREL is the SCVisit header on RMGrid ;alb/sat 658
I SVCR'="",SVCR'="BOTH" Q:(SVCR="NO")&($P(NOD,U,44)="") Q:SVCR'=$P(NOD,U,44) ;SERVICERELATED for filter (request)
I +SDSVC Q:$P(NOD,U,15)="" Q:'$D(SDSVC($P(NOD,U,15))) ;Service/Clinic Stop
S WAITD=$$FMDIFF^XLFDT($P($$NOW^XLFDT,".",1),$$CVTDT($P(NOD,U,8)))
S WAITD=9999999-WAITD ;Wait days for sorting
S ODTE=$P($$CVTDT($P(NOD,U,8)),".") ;Origination date for sorting
S DDTE=$P($$CVTDT($P(NOD,U,24)),".") ;Desired date for sorting
;S SORTSTR=$$SORT(.SORT)
S SORTSTR=$$SORT(.SORT,IEN,WAITD,TYP,PT,SVCPINV,PGRP,CLGP,DDTE,ODTE,SCPRI,.MGIENS,SVCREL) ;alb/sat 658 - add SVCREL
D SETNODE(WAITD,TYP,IEN,NOD,56,SORTSTR,.SDCNT)
;S SDCNT=SDCNT+1
Q
APPT(SDECY,MAXREC,DFN,SDBEG,SDEND,CLINIC,PRI,SCVISIT,SVCR,ORIGDT,DESDT,DESDTR,PRIGRP,SORT,PTS,SDMAX,URG,SDSVC,SDLASTA,ORIGDTR,SDCNT,MGIENS,SDALL,MRTC) ; EP get data from appt request file
Q:'$$TEST("ARGET^SDECAR1")
Q:+URG ;only check consults if urgency filter passed in
;Key stored in 56th piece
;SVCCONNP - 30th piece
;Desired DATE - 20th piece
;Origination Date - ORIGDT - 8th piece
;Priority Group - 26th piece
;IEN in 7th piece
N LP,NOD,GBL,DLM,SVCL,TYP,X
N RET,LASTSUB
S SDMAX=$G(SDMAX,50)
S SCVISIT=$G(SCVISIT)
S SVCR=$G(SVCR)
S SDSVC=$G(SDSVC)
S LASTSUB=""
S DLM="|",TYP="A"
S GBL="~SDEC(409.85,"
S MAXREC=$G(MAXREC),SDBEG=$G(SDBEG),SDEND=$G(SDEND),DFN=$G(DFN),CLINIC=$G(CLINIC)
S:SDBEG="" SDBEG=1410102 ;alb/sat 658 use valid FM range instead of 1000101
S:SDEND="" SDEND=$S(DFN'="":4141015,1:$$FMADD^XLFDT($$NOW^XLFDT,-90)) ;alb/sat 658 use valid FM range instead of 9991231
S SVCL="" S SDSVC=$G(SDSVC) I +SDSVC S SVCL=$$SVCL(.SDSVC)
S SDLASTA=$G(SDLASTA)
F D Q:SDLASTA="" Q:SDCNT'<SDMAX ;we throw some records out based on filters; continue until there are SDMAX records
.D ARGET^SDEC(.RET,,SDMAX-SDCNT,SDBEG,SDEND,DFN,SDLASTA,,SVCL,DESDT,PRI,SVCR,SCVISIT,CLINIC,ORIGDT)
.S X=$O(@RET@(9999999),-1) S NOD=@RET@(X) S SDLASTA=$P(NOD,U,56) ;get LASTSUB
.I 'X S SDLASTA="" Q
.S LP=0 F S LP=$O(@RET@(LP)) Q:LP="" D Q:SDCNT'<SDMAX
..S NOD=@RET@(LP)
..Q:$D(MGIENS("A"_$P(NOD,U,7)))
..D APPT1(MAXREC,DFN,SDBEG,SDEND,.CLINIC,.PRI,SCVISIT,SVCR,.ORIGDT,.DESDT,DESDTR,PRIGRP,.SORT,.PTS,SDMAX,.URG,.SDSVC,.SDLASTA,.ORIGDTR,.SDCNT,NOD,,.MRTC) ;alb/jsm 658 added MRTC
Q
APPT1(MAXREC,DFN,SDBEG,SDEND,CLINIC,PRI,SCVISIT,SVCR,ORIGDT,DESDT,DESDTR,PRIGRP,SORT,PTS,SDMAX,URG,SDSVC,SDLASTA,ORIGDTR,SDCNT,NOD,MGIENS,MRTC) ;get/check/process 1 entry
N CLGP,DDTE,DESGP,IEN,ODTE,ORIGGP,PGRP,PT,SCPRI,SORTSTR,SVCP,SVCPINV,TYP,WAITD
S TYP="A"
S PGRP=$P(NOD,U,26) ;compare to ENROLLMENT PRIORITY 22 instead of Patient's Priority Group in 26
I PGRP="" S PGRP="GROUP 0" ;Priority Grp
S PT=$P(NOD,U,1) ;Patient
I PTS'="",PT'="",$D(PTS(PT))=0 Q ;match clinic
I PRIGRP=1,$D(PRI(PGRP))=0 Q ;No match on priority group
S CLGP=$P(NOD,U,12)
I +CLINIC,$D(CLINIC(+CLGP))=0 Q ;match clinic
I CLGP'="",$$GET1^DIQ(44,CLGP_",",50.01,"I")=1 Q ;do not return if OOS? is yes
S DESGP=$P(NOD,U,20)
I DESDT'="",DESGP'="",$D(DESDT(DESGP))=0 Q ;match date of request with desired date
I DESDTR'="",DESGP'="",(DESGP<$P(DESDTR,"~",1))!(DESGP>$P(DESDTR,"~",2)) Q ;match date of request with range of desired dates
I (MRTC='""),(+MRTC'=+$P(NOD,U,23)) Q ;match multiple appointment RTC alb/jsm 658
S ORIGGP=$P(NOD,U,8)
I ORIGGP'="",(ORIGGP>SDEND)!(ORIGGP<SDBEG) Q
I ORIGDTR'="",ORIGGP'="",(ORIGGP<$P(ORIGDTR,"~",1))!(ORIGGP>$P(ORIGDTR,"~",2)) Q ;match origination date range with file entry date
I ORIGDT'="",ORIGGP'="",$D(ORIGDT(ORIGGP))=0 Q ;match origination date with file entry date
S IEN=$P(NOD,U,7)
S SVCP=$P(NOD,U,30)
S SVCPINV=100-SVCP
I SCVISIT'="",SCVISIT'="BOTH" Q:(SCVISIT="NO")&($P(NOD,U,29)="") Q:SCVISIT'=$P(NOD,U,29) ;SCVisit for filter (patient)
S SCPRI=$S($P(NOD,U,29)="YES":0,1:1) ;SCVisit for sorting
I SVCR'="",SVCR'="BOTH" Q:(SVCR="NO")&($P(NOD,U,37)="") Q:SVCR'=$P(NOD,U,37) ;SERVICERELATED for filter (request)
S SVCREL=$P(NOD,U,37)="YES" ;SVCREL is the SCVisit header on RMGrid alb/sat 658
I +SDSVC Q:$P(NOD,U,58)="" Q:'$D(SDSVC($P(NOD,U,58))) ;Service/Clinic Stop
S WAITD=$$FMDIFF^XLFDT($P($$NOW^XLFDT,".",1),$P(NOD,U,8))
S WAITD=9999999-WAITD
S ODTE=$P($$CVTDT($P(NOD,U,8)),".")
S DDTE=$P($$CVTDT($P(NOD,U,20)),".")
;S SORTSTR=$$SORT(.SORT)
S SORTSTR=$$SORT(.SORT,IEN,WAITD,TYP,PT,SVCPINV,PGRP,CLGP,DDTE,ODTE,SCPRI,.MGIENS,SVCREL) ;alb/sat 658 - add SVCREL
D SETNODE(WAITD,TYP,IEN,NOD,56,SORTSTR,.SDCNT)
;S SDCNT=SDCNT+1
Q
;
;Return recall list
RECALL(RET,MAXREC,DFN,SDBEG,SDEND,CLINIC,PRI,SCVISIT,SVCR,ORIGDT,DESDT,DESDTR,PRIGRP,SORT,PTS,SDMAX,URG,SDSVC,SDLASTR,ORIGDTR,SDCNT,MGIENS,SDALL) ;EP
Q:'$$TEST("RECGET^SDEC52")
Q:+URG ;only check consults if urgency filter passed in
;Key stored in 42nd piece
;SVCCONNP - 29th piece
;Desired DATE - 19th piece - External format
;Origination Date - ORIGDT - 32nd piece
;Priority Group - 25th piece
;IEN - 1st piece
N LP,NOD,GBL,SVCP,PG,DD,OD,DLM,TYP,PT,SORTSTR,SVCP,SCPRI,ORIGGP
N CLGP,IEN,PGRP,SDECY,SDI,SDCLL,SVCP,SVCPINV,LASTSUB,ODTE,DDTE,WAITD,X ;alb/sat 658 add SDI
Q:$G(SVCR)'="" ;only SD WAIT LIST and SDEC APPT REQUEST have this value
S SDCLL=""
S SDSVC=$G(SDSVC)
S SDMAX=$G(SDMAX,50)
S GBL="~SD(403.5,"
S DLM="|",TYP="R",LASTSUB=""
S DFN=$G(DFN),SDBEG=$G(SDBEG),SDEND=$G(SDEND),MAXREC=$G(MAXREC),SDLASTR=$G(SDLASTR),CLINIC=$G(CLINIC)
I $D(CLINIC) S SDI="" F S SDI=$O(CLINIC(SDI)) Q:SDI="" S SDCLL=SDCLL_$S(SDCLL'="":U,1:"")_SDI ;alb/sat 658
F D Q:SDLASTR="" Q:SDCNT'<SDMAX ;we throw some records out based on filters; continue until there are SDMAX records
.D RECGET^SDEC(.SDECY,DFN,SDBEG,SDEND,SDMAX-SDCNT,SDLASTR,,,1,SDCLL) ;alb/sat 658 add SDCLL param
.S X=$O(@SDECY@(9999999),-1) S NOD=@SDECY@(X) S SDLASTR=$P(NOD,U,42) ;get LASTSUB ;alb/sat 642 change 56 to 42
.I 'X S SDLASTR="" Q
.S LP=0 F S LP=$O(@SDECY@(LP)) Q:LP="" D
..S NOD=@SDECY@(LP)
..S CLGP=$P(NOD,U,16) Q:CLGP="" ;Clinic ID ;alb/sat 651
..S SVCP=$P(NOD,U,29) ;Service connected percentage
..S SVCPINV=100-SVCP
..S PGRP=$P(NOD,U,25)
..S PT=$P(NOD,U,2) ;Patient
..I PTS'="",PT'="",$D(PTS(PT))=0 Q
..I PGRP="" S PGRP="GROUP 0" ;Priority Grp
..I PRIGRP'="",$D(PRI(PGRP))=0 Q ;No match on priority group
..I +CLINIC,CLGP'="",$D(CLINIC(CLGP))=0 Q ;match clinic
..I CLGP'="",$$GET1^DIQ(44,CLGP_",",50.01,"I")=1 Q ;do not return if OOS? is yes
..I +SDSVC N SDSVCN S SDSVCN=$$GET1^DIQ(44,+$P(NOD,U,16)_",",8,"E") Q:SDSVCN="" Q:'$D(SDSVC(SDSVCN)) ;check service
..S DESGP=$P(NOD,U,19) I DESGP'="" S %DT="",X=DESGP D ^%DT S DESGP=$S(Y=-1:"",1:Y) ;alb/sat 658 use internal time
..I DESDT'="",DESGP'="",$D(DESDT(DESGP))=0 Q ;match date of request with desired date
..I DESDTR'="",DESGP'="",(DESGP<$P(DESDTR,"~",1))!(DESGP>$P(DESDTR,"~",2)) Q ;match date of request with range of desired dates
..S ORIGGP=$P(NOD,U,32)
..I ORIGDTR'="",ORIGGP'="",(ORIGGP<$P(ORIGDTR,"~",1))!(ORIGGP>$P(ORIGDTR,"~",2)) Q ;match origination date range with file entry date
..I ORIGDT'="",ORIGGP'="",$D(ORIGDT(ORIGGP))=0 Q ;match origination date with file entry date
..S IEN=$P(NOD,U,1)
..I SCVISIT'="",SCVISIT'="BOTH" Q:(SCVISIT="NO")&($P(NOD,U,28)="") Q:SCVISIT'=$P(NOD,U,28) ;SCVisit for filter (patient)
..S SCPRI=0 ;SCVisit for sorting
..S SVCREL=$S(PGRP="GROUP 1":1,1:"") ;SVCREL is the SCVisit header on RMGrid; Service Related alb/sat 658 - If Priority Group 1, treat as service related as 'YES', treat as 'NO' for all other Priority Groups.
..S WAITD=$$FMDIFF^XLFDT($P($$NOW^XLFDT,".",1),$$CVTDT($P(NOD,U,19)))
..S WAITD=9999999-WAITD
..S ODTE=$P($$CVTDT($P(NOD,U,32)),".")
..S DDTE=$P($$CVTDT($P(NOD,U,19)),".")
..;S SORTSTR=$$SORT(.SORT)
..S SORTSTR=$$SORT(.SORT,IEN,WAITD,TYP,PT,SVCPINV,PGRP,CLGP,DDTE,ODTE,SCPRI,,SVCREL) ;alb/sat 658 - add SVCREL
..D SETNODE(WAITD,TYP,IEN,NOD,42,SORTSTR,.SDCNT)
..;S SDCNT=SDCNT+1
Q
;
SETNODE(S1,S2,S3,VAL,KEYP,SLIST,CNT) ;EP-
; S1 =Wait Days
; S2 =Request Type - A C E R
; S3 =Request Type IEN
; VAL = Request Type data from rpc call
; KEYP = Storage piece number where LASTSUB is stored
; SLIST = Sort String from $$SORT
Q:'$L($D(S1))!'$L($D(S2))!'$L($D(S3))
N KEY,DLM
S DLM="|"
Q:$D(^TMP("SDECIDX",$J,"XREF-ID",S2_DLM_S3)) ;quit if duplicate
;S KEY=9999999-S1_DLM_S2_DLM_S3_DLM_SLIST
S KEY=SLIST_DLM_S3
S CNT=$G(CNT)+1
S VAL=$P(VAL,$C(30))
S:$G(KEYP) $P(VAL,U,KEYP)=KEY
S ^TMP("SDECIDX",$J,"DATA",CNT)=$G(VAL)
S ^TMP("SDECIDX",$J,"XREF",KEY)=S2_U_S3_U_KEY
S ^TMP("SDECIDX",$J,"COUNT")=CNT
S ^TMP("SDECIDX",$J,"XREF-ID",S2_DLM_S3)=""
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))
;
;SORT(SORT) ;Sort out the variables
SORT(SORT,IEN,WAITD,TYP,PT,SVCPINV,PGRP,CLGP,DDTE,ODTE,SCPRI,MGIENS,SVCREL) ;alb/sat 658 - add SVCREL
N SOR,SCNT,SD,STRING,DLM,STR
N STCNT,STID,STJ,STTYP
S SCNT=0,(STR,STRING)="",DLM="|"
I $D(MGIENS(TYP_IEN)) S STRING="0|0|0"
S SOR="" F S SOR=$O(SORT(SOR)) Q:SOR'>0 D
.S SCNT=SCNT+1
.S SD=$G(SORT(SOR))
.S STR=""
.S STR=$S(SD="RTOPD":$S(TYP="R":0,1:1),SD="ATOPD":$S(TYP="A":0,1:1),SD="ETOPD":$S(TYP="E":0,1:1),SD="CTOPD":$S(TYP="C":0,1:1),1:"")
.S:STR=0 STR=STR_"|"_$$PAD(999999999-IEN)
.I SD="PRIORITYGROUP" D
..S STR=$S(PGRP="GROUP 0":0,PGRP="GROUP 1":1,PGRP="GROUP 2":2,PGRP="GROUP 3":3,PGRP="GROUP 4":4,PGRP="GROUP 5":5,PGRP="GROUP 6":6,PGRP="GROUP 7":7,PGRP="GROUP 8":8,1:0)
..S STR=STR_DLM_'SVCREL ;SVCREL is SCVISIT header on RMGRID ;alb/sat 658
.S:STR="" STR=$S(SD="WAITTIME":WAITD,SD="REQUESTTYPE":TYP,SD="PATIENTNAME":PT,SD="SCVISIT":SVCPINV,SD="CLINICS":CLGP,SD="DESIREDDATE":DDTE,SD="ORIGINATIONDATE":ODTE,1:"")
.I SD="PATIENTNAME" S STR=$$GET1^DIQ(2,PT_",",.01)
.I SD="CLINICS" S STR=$$GET1^DIQ(44,CLGP_",",.01)
.I STRING="" S STRING=STR
.E S STRING=STRING_DLM_STR
Q STRING
;
PAD(STRING,CHAR,CNT) ;prepend characters (default is 0 zero) to STRING
N SDI,SDR
S STRING=$G(STRING)
S CHAR=$G(CHAR)
S:CHAR="" CHAR="0"
S CNT=$G(CNT)
S:+CNT CNT=+CNT+1
S:'+CNT CNT=10 ;(9 characters)
S $P(SDR,CHAR,CNT-$L(STRING))=STRING
Q SDR
; 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)'="")
;
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(^TMP("SDECIDX",$J,"COUNT"))
Q
SVCL(SDSVC) ;build services list
N SDI,SDR,SVC
S SDR=""
S SDI=0 F S SDI=$O(SDSVC(SDI)) Q:SDI="" D
.S SVC=SDSVC(SDI)
.Q:SVC=""
.S SDR=SDR_$S(SDR'="":"|",1:"")_SVC
Q SDR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDECRMG1 14870 printed Dec 13, 2024@02:52:29 Page 2
SDECRMG1 ;ALB/SAT/JSM - VISTA SCHEDULING RPCS ;MAR 15, 2017
+1 ;;5.3;Scheduling;**627,642,651,658**;Aug 13, 1993;Build 23
+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.
WAIT(SDCY,MAXREC,DFN,SDBEG,SDEND,CLINIC,PRI,SCVISIT,SVCR,ORIGDT,DESDT,DESDTR,PRIGRP,SORT,PTS,SDMAX,URG,SDSVC,SDLASTE,ORIGDTR,SDCNT,MGIENS,SDALL) ;EP
+1 ;Key stored in 56th piece
+2 ;SVCCONNP - 37th piece
+3 ;Desired DATE - 24th piece
+4 ;Origination Date - ORIGDT - 8th piece
+5 ;Priority Group - 33th piece
+6 ;IEN in 7th piece
+7 ;only check consults if urgency filter passed in
if +URG
QUIT
+8 NEW %DT,LP,NOD,GBL,DLM,TYP,SDCF,SDI,SVCL,X,Y
+9 NEW RET,WLIEN1,LASTSUB
+10 SET SVCL=""
+11 SET SDCF=1
+12 IF +CLINIC
SET SDCF=0
Begin DoDot:1
+13 SET SDI=""
FOR
SET SDI=$ORDER(CLINIC(SDI))
if SDI=""
QUIT
Begin DoDot:2
+14 if $ORDER(^SDWL(409.32,"B",SDI,0))
SET SDCF=1
End DoDot:2
if SDCF=1
QUIT
End DoDot:1
+15 if '+SDCF
QUIT
+16 SET SDMAX=$GET(SDMAX,50)
+17 SET GBL="~SDWL(409.3,"
+18 SET DLM="|"
SET TYP="E"
SET LASTSUB=""
+19 SET WLIEN1=$GET(WLIEN1)
SET MAXREC=$GET(MAXREC)
SET SDBEG=$GET(SDBEG)
SET SDEND=$GET(SDEND)
SET DFN=$GET(DFN)
SET CLINIC=$GET(CLINIC)
+20 ;alb/sat 658 use valid FM range instead of 1000101
if SDBEG=""
SET SDBEG=1410102
+21 ;alb/sat 658 use valid FM range instead of 9991231
if SDEND=""
SET SDEND=$SELECT(DFN'="":4141015,1:$$FMADD^XLFDT($$NOW^XLFDT,-90))
+22 SET SCVISIT=$GET(SCVISIT)
+23 SET SVCR=$GET(SVCR)
+24 SET SDSVC=$GET(SDSVC)
IF +SDSVC
SET SVCL=$$SVCL(.SDSVC)
+25 SET SDLASTE=$GET(SDLASTE)
+26 FOR
Begin DoDot:1
+27 ;alb/sat 658 add SVCL...
DO WLGET^SDEC(.RET,WLIEN1,SDMAX-SDCNT,SDBEG,SDEND,DFN,SDLASTE,+$DATA(SORT("B","ETOPD")),SVCL,DESDT,PRI,SVCR,SCVISIT,CLINIC,ORIGDT)
+28 SET X=$ORDER(@RET@(9999999),-1)
SET NOD=@RET@(X)
SET SDLASTE=$PIECE(NOD,U,56)
+29 IF 'X
SET SDLASTE=""
QUIT
+30 SET LP=0
FOR
SET LP=$ORDER(@RET@(LP))
if LP=""
QUIT
Begin DoDot:2
+31 SET NOD=@RET@(LP)
+32 if $DATA(MGIENS("E"_$PIECE(NOD,U,7)))
QUIT
+33 DO WAIT1(MAXREC,DFN,SDBEG,SDEND,.CLINIC,.PRI,SCVISIT,SVCR,.ORIGDT,.DESDT,DESDTR,PRIGRP,.SORT,.PTS,SDMAX,.URG,.SDSVC,.SDLASTA,.ORIGDTR,.SDCNT,NOD)
End DoDot:2
if SDCNT'<SDMAX
QUIT
End DoDot:1
if SDLASTE=""
QUIT
if SDCNT'<SDMAX
QUIT
+34 QUIT
WAIT1(MAXREC,DFN,SDBEG,SDEND,CLINIC,PRI,SCVISIT,SVCR,ORIGDT,DESDT,DESDTR,PRIGRP,SORT,PTS,SDMAX,URG,SDSVC,SDLASTA,ORIGDTR,SDCNT,NOD,MGIENS,SDALL) ;get/check/process 1 entry
+1 NEW CLGP,DDTE,DESGP,IEN,ODTE,ORIGGP,PGRP,PT,SCPRI,SORTSTR,SVCP,SVCPINV,TYP,WAITD
+2 SET TYP="E"
+3 ;compare to ENROLLMENT PRIORITY 28 instead of Patient's Priority Group in 33
SET PGRP=$PIECE(NOD,U,33)
+4 SET PT=$PIECE(NOD,U,1)
+5 ;No match on patients
IF PTS'=""
IF PT'=""
IF $DATA(PTS(PT))=0
QUIT
+6 IF PGRP=""
SET PGRP="GROUP 0"
+7 ;No match on priority group
IF PRIGRP=1
IF $DATA(PRI(PGRP))=0
QUIT
+8 ;I CLGP'="" S CLGP=$$GET1^DIQ(409.32,CLGP_",",.01,"I")
SET CLGP=$PIECE(NOD,U,16)
+9 IF +CLINIC
IF CLGP=""
QUIT
+10 ;match clinic filter
IF +CLINIC
IF CLGP'=""
IF $DATA(CLINIC(CLGP))=0
QUIT
+11 ;do not return if OOS? is yes
IF CLGP'=""
IF $$GET1^DIQ(44,CLGP_",",50.01,"I")=1
QUIT
+12 SET DESGP=$PIECE(NOD,U,24)
+13 ;match date of request with desired date
IF DESDT'=""
IF DESGP'=""
IF $DATA(DESDT(DESGP))=0
QUIT
+14 ;match date of request with range of desired dates
IF DESDTR'=""
IF DESGP'=""
IF (DESGP<$PIECE(DESDTR,"~",1))!(DESGP>$PIECE(DESDTR,"~",2))
QUIT
+15 SET ORIGGP=$PIECE(NOD,U,8)
+16 ;match origination date range with file entry date
IF ORIGDTR'=""
IF ORIGGP'=""
IF (ORIGGP<$PIECE(ORIGDTR,"~",1))!(ORIGGP>$PIECE(ORIGDTR,"~",2))
QUIT
+17 ;match origination date with file entry date
IF ORIGDT'=""
IF ORIGGP'=""
IF $DATA(ORIGDT(ORIGGP))=0
QUIT
+18 SET IEN=$PIECE(NOD,U,7)
+19 SET SVCP=$PIECE(NOD,U,37)
+20 SET SVCPINV=100-SVCP
+21 ;SCVisit for filter (patient)
IF SCVISIT'=""
IF SCVISIT'="BOTH"
if (SCVISIT="NO")&($PIECE(NOD,U,36)="")
QUIT
if SCVISIT'=$PIECE(NOD,U,36)
QUIT
+22 SET SCPRI=$PIECE(NOD,U,26)="YES"
+23 ;SVCREL is the SCVisit header on RMGrid ;alb/sat 658
SET SVCREL=$PIECE(NOD,U,44)="YES"
+24 ;SERVICERELATED for filter (request)
IF SVCR'=""
IF SVCR'="BOTH"
if (SVCR="NO")&($PIECE(NOD,U,44)="")
QUIT
if SVCR'=$PIECE(NOD,U,44)
QUIT
+25 ;Service/Clinic Stop
IF +SDSVC
if $PIECE(NOD,U,15)=""
QUIT
if '$DATA(SDSVC($PIECE(NOD,U,15)))
QUIT
+26 SET WAITD=$$FMDIFF^XLFDT($PIECE($$NOW^XLFDT,".",1),$$CVTDT($PIECE(NOD,U,8)))
+27 ;Wait days for sorting
SET WAITD=9999999-WAITD
+28 ;Origination date for sorting
SET ODTE=$PIECE($$CVTDT($PIECE(NOD,U,8)),".")
+29 ;Desired date for sorting
SET DDTE=$PIECE($$CVTDT($PIECE(NOD,U,24)),".")
+30 ;S SORTSTR=$$SORT(.SORT)
+31 ;alb/sat 658 - add SVCREL
SET SORTSTR=$$SORT(.SORT,IEN,WAITD,TYP,PT,SVCPINV,PGRP,CLGP,DDTE,ODTE,SCPRI,.MGIENS,SVCREL)
+32 DO SETNODE(WAITD,TYP,IEN,NOD,56,SORTSTR,.SDCNT)
+33 ;S SDCNT=SDCNT+1
+34 QUIT
APPT(SDECY,MAXREC,DFN,SDBEG,SDEND,CLINIC,PRI,SCVISIT,SVCR,ORIGDT,DESDT,DESDTR,PRIGRP,SORT,PTS,SDMAX,URG,SDSVC,SDLASTA,ORIGDTR,SDCNT,MGIENS,SDALL,MRTC) ; EP get data from appt request file
+1 if '$$TEST("ARGET^SDECAR1")
QUIT
+2 ;only check consults if urgency filter passed in
if +URG
QUIT
+3 ;Key stored in 56th piece
+4 ;SVCCONNP - 30th piece
+5 ;Desired DATE - 20th piece
+6 ;Origination Date - ORIGDT - 8th piece
+7 ;Priority Group - 26th piece
+8 ;IEN in 7th piece
+9 NEW LP,NOD,GBL,DLM,SVCL,TYP,X
+10 NEW RET,LASTSUB
+11 SET SDMAX=$GET(SDMAX,50)
+12 SET SCVISIT=$GET(SCVISIT)
+13 SET SVCR=$GET(SVCR)
+14 SET SDSVC=$GET(SDSVC)
+15 SET LASTSUB=""
+16 SET DLM="|"
SET TYP="A"
+17 SET GBL="~SDEC(409.85,"
+18 SET MAXREC=$GET(MAXREC)
SET SDBEG=$GET(SDBEG)
SET SDEND=$GET(SDEND)
SET DFN=$GET(DFN)
SET CLINIC=$GET(CLINIC)
+19 ;alb/sat 658 use valid FM range instead of 1000101
if SDBEG=""
SET SDBEG=1410102
+20 ;alb/sat 658 use valid FM range instead of 9991231
if SDEND=""
SET SDEND=$SELECT(DFN'="":4141015,1:$$FMADD^XLFDT($$NOW^XLFDT,-90))
+21 SET SVCL=""
SET SDSVC=$GET(SDSVC)
IF +SDSVC
SET SVCL=$$SVCL(.SDSVC)
+22 SET SDLASTA=$GET(SDLASTA)
+23 ;we throw some records out based on filters; continue until there are SDMAX records
FOR
Begin DoDot:1
+24 DO ARGET^SDEC(.RET,,SDMAX-SDCNT,SDBEG,SDEND,DFN,SDLASTA,,SVCL,DESDT,PRI,SVCR,SCVISIT,CLINIC,ORIGDT)
+25 ;get LASTSUB
SET X=$ORDER(@RET@(9999999),-1)
SET NOD=@RET@(X)
SET SDLASTA=$PIECE(NOD,U,56)
+26 IF 'X
SET SDLASTA=""
QUIT
+27 SET LP=0
FOR
SET LP=$ORDER(@RET@(LP))
if LP=""
QUIT
Begin DoDot:2
+28 SET NOD=@RET@(LP)
+29 if $DATA(MGIENS("A"_$PIECE(NOD,U,7)))
QUIT
+30 ;alb/jsm 658 added MRTC
DO APPT1(MAXREC,DFN,SDBEG,SDEND,.CLINIC,.PRI,SCVISIT,SVCR,.ORIGDT,.DESDT,DESDTR,PRIGRP,.SORT,.PTS,SDMAX,.URG,.SDSVC,.SDLASTA,.ORIGDTR,.SDCNT,NOD,,.MRTC)
End DoDot:2
if SDCNT'<SDMAX
QUIT
End DoDot:1
if SDLASTA=""
QUIT
if SDCNT'<SDMAX
QUIT
+31 QUIT
APPT1(MAXREC,DFN,SDBEG,SDEND,CLINIC,PRI,SCVISIT,SVCR,ORIGDT,DESDT,DESDTR,PRIGRP,SORT,PTS,SDMAX,URG,SDSVC,SDLASTA,ORIGDTR,SDCNT,NOD,MGIENS,MRTC) ;get/check/process 1 entry
+1 NEW CLGP,DDTE,DESGP,IEN,ODTE,ORIGGP,PGRP,PT,SCPRI,SORTSTR,SVCP,SVCPINV,TYP,WAITD
+2 SET TYP="A"
+3 ;compare to ENROLLMENT PRIORITY 22 instead of Patient's Priority Group in 26
SET PGRP=$PIECE(NOD,U,26)
+4 ;Priority Grp
IF PGRP=""
SET PGRP="GROUP 0"
+5 ;Patient
SET PT=$PIECE(NOD,U,1)
+6 ;match clinic
IF PTS'=""
IF PT'=""
IF $DATA(PTS(PT))=0
QUIT
+7 ;No match on priority group
IF PRIGRP=1
IF $DATA(PRI(PGRP))=0
QUIT
+8 SET CLGP=$PIECE(NOD,U,12)
+9 ;match clinic
IF +CLINIC
IF $DATA(CLINIC(+CLGP))=0
QUIT
+10 ;do not return if OOS? is yes
IF CLGP'=""
IF $$GET1^DIQ(44,CLGP_",",50.01,"I")=1
QUIT
+11 SET DESGP=$PIECE(NOD,U,20)
+12 ;match date of request with desired date
IF DESDT'=""
IF DESGP'=""
IF $DATA(DESDT(DESGP))=0
QUIT
+13 ;match date of request with range of desired dates
IF DESDTR'=""
IF DESGP'=""
IF (DESGP<$PIECE(DESDTR,"~",1))!(DESGP>$PIECE(DESDTR,"~",2))
QUIT
+14 ;match multiple appointment RTC alb/jsm 658
IF (MRTC='"")
IF (+MRTC'=+$PIECE(NOD,U,23))
QUIT
+15 SET ORIGGP=$PIECE(NOD,U,8)
+16 IF ORIGGP'=""
IF (ORIGGP>SDEND)!(ORIGGP<SDBEG)
QUIT
+17 ;match origination date range with file entry date
IF ORIGDTR'=""
IF ORIGGP'=""
IF (ORIGGP<$PIECE(ORIGDTR,"~",1))!(ORIGGP>$PIECE(ORIGDTR,"~",2))
QUIT
+18 ;match origination date with file entry date
IF ORIGDT'=""
IF ORIGGP'=""
IF $DATA(ORIGDT(ORIGGP))=0
QUIT
+19 SET IEN=$PIECE(NOD,U,7)
+20 SET SVCP=$PIECE(NOD,U,30)
+21 SET SVCPINV=100-SVCP
+22 ;SCVisit for filter (patient)
IF SCVISIT'=""
IF SCVISIT'="BOTH"
if (SCVISIT="NO")&($PIECE(NOD,U,29)="")
QUIT
if SCVISIT'=$PIECE(NOD,U,29)
QUIT
+23 ;SCVisit for sorting
SET SCPRI=$SELECT($PIECE(NOD,U,29)="YES":0,1:1)
+24 ;SERVICERELATED for filter (request)
IF SVCR'=""
IF SVCR'="BOTH"
if (SVCR="NO")&($PIECE(NOD,U,37)="")
QUIT
if SVCR'=$PIECE(NOD,U,37)
QUIT
+25 ;SVCREL is the SCVisit header on RMGrid alb/sat 658
SET SVCREL=$PIECE(NOD,U,37)="YES"
+26 ;Service/Clinic Stop
IF +SDSVC
if $PIECE(NOD,U,58)=""
QUIT
if '$DATA(SDSVC($PIECE(NOD,U,58)))
QUIT
+27 SET WAITD=$$FMDIFF^XLFDT($PIECE($$NOW^XLFDT,".",1),$PIECE(NOD,U,8))
+28 SET WAITD=9999999-WAITD
+29 SET ODTE=$PIECE($$CVTDT($PIECE(NOD,U,8)),".")
+30 SET DDTE=$PIECE($$CVTDT($PIECE(NOD,U,20)),".")
+31 ;S SORTSTR=$$SORT(.SORT)
+32 ;alb/sat 658 - add SVCREL
SET SORTSTR=$$SORT(.SORT,IEN,WAITD,TYP,PT,SVCPINV,PGRP,CLGP,DDTE,ODTE,SCPRI,.MGIENS,SVCREL)
+33 DO SETNODE(WAITD,TYP,IEN,NOD,56,SORTSTR,.SDCNT)
+34 ;S SDCNT=SDCNT+1
+35 QUIT
+36 ;
+37 ;Return recall list
RECALL(RET,MAXREC,DFN,SDBEG,SDEND,CLINIC,PRI,SCVISIT,SVCR,ORIGDT,DESDT,DESDTR,PRIGRP,SORT,PTS,SDMAX,URG,SDSVC,SDLASTR,ORIGDTR,SDCNT,MGIENS,SDALL) ;EP
+1 if '$$TEST("RECGET^SDEC52")
QUIT
+2 ;only check consults if urgency filter passed in
if +URG
QUIT
+3 ;Key stored in 42nd piece
+4 ;SVCCONNP - 29th piece
+5 ;Desired DATE - 19th piece - External format
+6 ;Origination Date - ORIGDT - 32nd piece
+7 ;Priority Group - 25th piece
+8 ;IEN - 1st piece
+9 NEW LP,NOD,GBL,SVCP,PG,DD,OD,DLM,TYP,PT,SORTSTR,SVCP,SCPRI,ORIGGP
+10 ;alb/sat 658 add SDI
NEW CLGP,IEN,PGRP,SDECY,SDI,SDCLL,SVCP,SVCPINV,LASTSUB,ODTE,DDTE,WAITD,X
+11 ;only SD WAIT LIST and SDEC APPT REQUEST have this value
if $GET(SVCR)'=""
QUIT
+12 SET SDCLL=""
+13 SET SDSVC=$GET(SDSVC)
+14 SET SDMAX=$GET(SDMAX,50)
+15 SET GBL="~SD(403.5,"
+16 SET DLM="|"
SET TYP="R"
SET LASTSUB=""
+17 SET DFN=$GET(DFN)
SET SDBEG=$GET(SDBEG)
SET SDEND=$GET(SDEND)
SET MAXREC=$GET(MAXREC)
SET SDLASTR=$GET(SDLASTR)
SET CLINIC=$GET(CLINIC)
+18 ;alb/sat 658
IF $DATA(CLINIC)
SET SDI=""
FOR
SET SDI=$ORDER(CLINIC(SDI))
if SDI=""
QUIT
SET SDCLL=SDCLL_$SELECT(SDCLL'="":U,1:"")_SDI
+19 ;we throw some records out based on filters; continue until there are SDMAX records
FOR
Begin DoDot:1
+20 ;alb/sat 658 add SDCLL param
DO RECGET^SDEC(.SDECY,DFN,SDBEG,SDEND,SDMAX-SDCNT,SDLASTR,,,1,SDCLL)
+21 ;get LASTSUB ;alb/sat 642 change 56 to 42
SET X=$ORDER(@SDECY@(9999999),-1)
SET NOD=@SDECY@(X)
SET SDLASTR=$PIECE(NOD,U,42)
+22 IF 'X
SET SDLASTR=""
QUIT
+23 SET LP=0
FOR
SET LP=$ORDER(@SDECY@(LP))
if LP=""
QUIT
Begin DoDot:2
+24 SET NOD=@SDECY@(LP)
+25 ;Clinic ID ;alb/sat 651
SET CLGP=$PIECE(NOD,U,16)
if CLGP=""
QUIT
+26 ;Service connected percentage
SET SVCP=$PIECE(NOD,U,29)
+27 SET SVCPINV=100-SVCP
+28 SET PGRP=$PIECE(NOD,U,25)
+29 ;Patient
SET PT=$PIECE(NOD,U,2)
+30 IF PTS'=""
IF PT'=""
IF $DATA(PTS(PT))=0
QUIT
+31 ;Priority Grp
IF PGRP=""
SET PGRP="GROUP 0"
+32 ;No match on priority group
IF PRIGRP'=""
IF $DATA(PRI(PGRP))=0
QUIT
+33 ;match clinic
IF +CLINIC
IF CLGP'=""
IF $DATA(CLINIC(CLGP))=0
QUIT
+34 ;do not return if OOS? is yes
IF CLGP'=""
IF $$GET1^DIQ(44,CLGP_",",50.01,"I")=1
QUIT
+35 ;check service
IF +SDSVC
NEW SDSVCN
SET SDSVCN=$$GET1^DIQ(44,+$PIECE(NOD,U,16)_",",8,"E")
if SDSVCN=""
QUIT
if '$DATA(SDSVC(SDSVCN))
QUIT
+36 ;alb/sat 658 use internal time
SET DESGP=$PIECE(NOD,U,19)
IF DESGP'=""
SET %DT=""
SET X=DESGP
DO ^%DT
SET DESGP=$SELECT(Y=-1:"",1:Y)
+37 ;match date of request with desired date
IF DESDT'=""
IF DESGP'=""
IF $DATA(DESDT(DESGP))=0
QUIT
+38 ;match date of request with range of desired dates
IF DESDTR'=""
IF DESGP'=""
IF (DESGP<$PIECE(DESDTR,"~",1))!(DESGP>$PIECE(DESDTR,"~",2))
QUIT
+39 SET ORIGGP=$PIECE(NOD,U,32)
+40 ;match origination date range with file entry date
IF ORIGDTR'=""
IF ORIGGP'=""
IF (ORIGGP<$PIECE(ORIGDTR,"~",1))!(ORIGGP>$PIECE(ORIGDTR,"~",2))
QUIT
+41 ;match origination date with file entry date
IF ORIGDT'=""
IF ORIGGP'=""
IF $DATA(ORIGDT(ORIGGP))=0
QUIT
+42 SET IEN=$PIECE(NOD,U,1)
+43 ;SCVisit for filter (patient)
IF SCVISIT'=""
IF SCVISIT'="BOTH"
if (SCVISIT="NO")&($PIECE(NOD,U,28)="")
QUIT
if SCVISIT'=$PIECE(NOD,U,28)
QUIT
+44 ;SCVisit for sorting
SET SCPRI=0
+45 ;SVCREL is the SCVisit header on RMGrid; Service Related alb/sat 658 - If Priority Group 1, treat as service related as 'YES', treat as 'NO' for all other Priority Groups.
SET SVCREL=$SELECT(PGRP="GROUP 1":1,1:"")
+46 SET WAITD=$$FMDIFF^XLFDT($PIECE($$NOW^XLFDT,".",1),$$CVTDT($PIECE(NOD,U,19)))
+47 SET WAITD=9999999-WAITD
+48 SET ODTE=$PIECE($$CVTDT($PIECE(NOD,U,32)),".")
+49 SET DDTE=$PIECE($$CVTDT($PIECE(NOD,U,19)),".")
+50 ;S SORTSTR=$$SORT(.SORT)
+51 ;alb/sat 658 - add SVCREL
SET SORTSTR=$$SORT(.SORT,IEN,WAITD,TYP,PT,SVCPINV,PGRP,CLGP,DDTE,ODTE,SCPRI,,SVCREL)
+52 DO SETNODE(WAITD,TYP,IEN,NOD,42,SORTSTR,.SDCNT)
+53 ;S SDCNT=SDCNT+1
End DoDot:2
End DoDot:1
if SDLASTR=""
QUIT
if SDCNT'<SDMAX
QUIT
+54 QUIT
+55 ;
SETNODE(S1,S2,S3,VAL,KEYP,SLIST,CNT) ;EP-
+1 ; S1 =Wait Days
+2 ; S2 =Request Type - A C E R
+3 ; S3 =Request Type IEN
+4 ; VAL = Request Type data from rpc call
+5 ; KEYP = Storage piece number where LASTSUB is stored
+6 ; SLIST = Sort String from $$SORT
+7 if '$LENGTH($DATA(S1))!'$LENGTH($DATA(S2))!'$LENGTH($DATA(S3))
QUIT
+8 NEW KEY,DLM
+9 SET DLM="|"
+10 ;quit if duplicate
if $DATA(^TMP("SDECIDX",$JOB,"XREF-ID",S2_DLM_S3))
QUIT
+11 ;S KEY=9999999-S1_DLM_S2_DLM_S3_DLM_SLIST
+12 SET KEY=SLIST_DLM_S3
+13 SET CNT=$GET(CNT)+1
+14 SET VAL=$PIECE(VAL,$CHAR(30))
+15 if $GET(KEYP)
SET $PIECE(VAL,U,KEYP)=KEY
+16 SET ^TMP("SDECIDX",$JOB,"DATA",CNT)=$GET(VAL)
+17 SET ^TMP("SDECIDX",$JOB,"XREF",KEY)=S2_U_S3_U_KEY
+18 SET ^TMP("SDECIDX",$JOB,"COUNT")=CNT
+19 SET ^TMP("SDECIDX",$JOB,"XREF-ID",S2_DLM_S3)=""
+20 QUIT
+21 ;
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 ;SORT(SORT) ;Sort out the variables
SORT(SORT,IEN,WAITD,TYP,PT,SVCPINV,PGRP,CLGP,DDTE,ODTE,SCPRI,MGIENS,SVCREL) ;alb/sat 658 - add SVCREL
+1 NEW SOR,SCNT,SD,STRING,DLM,STR
+2 NEW STCNT,STID,STJ,STTYP
+3 SET SCNT=0
SET (STR,STRING)=""
SET DLM="|"
+4 IF $DATA(MGIENS(TYP_IEN))
SET STRING="0|0|0"
+5 SET SOR=""
FOR
SET SOR=$ORDER(SORT(SOR))
if SOR'>0
QUIT
Begin DoDot:1
+6 SET SCNT=SCNT+1
+7 SET SD=$GET(SORT(SOR))
+8 SET STR=""
+9 SET STR=$SELECT(SD="RTOPD":$SELECT(TYP="R":0,1:1),SD="ATOPD":$SELECT(TYP="A":0,1:1),SD="ETOPD":$SELECT(TYP="E":0,1:1),SD="CTOPD":$SELECT(TYP="C":0,1:1),1:"")
+10 if STR=0
SET STR=STR_"|"_$$PAD(999999999-IEN)
+11 IF SD="PRIORITYGROUP"
Begin DoDot:2
+12 SET STR=$SELECT(PGRP="GROUP 0":0,PGRP="GROUP 1":1,PGRP="GROUP 2":2,PGRP="GROUP 3":3,PGRP="GROUP 4":4,PGRP="GROUP 5":5,PGRP="GROUP 6":6,PGRP="GROUP 7":7,PGRP="GROUP 8":8,1:0)
+13 ;SVCREL is SCVISIT header on RMGRID ;alb/sat 658
SET STR=STR_DLM_'SVCREL
End DoDot:2
+14 if STR=""
SET STR=$SELECT(SD="WAITTIME":WAITD,SD="REQUESTTYPE":TYP,SD="PATIENTNAME":PT,SD="SCVISIT":SVCPINV,SD="CLINICS":CLGP,SD="DESIREDDATE":DDTE,SD="ORIGINATIONDATE":ODTE,1:"")
+15 IF SD="PATIENTNAME"
SET STR=$$GET1^DIQ(2,PT_",",.01)
+16 IF SD="CLINICS"
SET STR=$$GET1^DIQ(44,CLGP_",",.01)
+17 IF STRING=""
SET STRING=STR
+18 IF '$TEST
SET STRING=STRING_DLM_STR
End DoDot:1
+19 QUIT STRING
+20 ;
PAD(STRING,CHAR,CNT) ;prepend characters (default is 0 zero) to STRING
+1 NEW SDI,SDR
+2 SET STRING=$GET(STRING)
+3 SET CHAR=$GET(CHAR)
+4 if CHAR=""
SET CHAR="0"
+5 SET CNT=$GET(CNT)
+6 if +CNT
SET CNT=+CNT+1
+7 ;(9 characters)
if '+CNT
SET CNT=10
+8 SET $PIECE(SDR,CHAR,CNT-$LENGTH(STRING))=STRING
+9 QUIT SDR
+10 ; 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 ;
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(^TMP("SDECIDX",$JOB,"COUNT"))
+2 QUIT
SVCL(SDSVC) ;build services list
+1 NEW SDI,SDR,SVC
+2 SET SDR=""
+3 SET SDI=0
FOR
SET SDI=$ORDER(SDSVC(SDI))
if SDI=""
QUIT
Begin DoDot:1
+4 SET SVC=SDSVC(SDI)
+5 if SVC=""
QUIT
+6 SET SDR=SDR_$SELECT(SDR'="":"|",1:"")_SVC
End DoDot:1
+7 QUIT SDR
