- 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 Feb 19, 2025@00:18:55 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