SDECRMG2 ;ALB/SAT/JSM - VISTA SCHEDULING RPCS ;MAR 15, 2017
;;5.3;Scheduling;**627,642,651,658**;Aug 13, 1993;Build 23
;
;Reference is made to ICR #6185
Q
;
URGENCY(SDECY) ;GET valid urgency protocol values that are used in the URGENCY field 5 of the REQUEST CONSULTAION file 123
;INPUT: none
;RETURN:
; Global array in which each entry contains the IEN and NAME of a protocol entry
; 1. IEN - pointer to PROTOCOL file 101
; 2. NAME - name field from PROTOCOL file
; 3. SYNONYM - Short name list separated by pipe.
; Synonym that might be what is recognized by the users
N SDECI,SDI,SDID,SDJ,SDK,SDNAME,SDSYN
S SDECY="^TMP(""SDECRMG2"","_$J_",""URGENCY"")"
K @SDECY
S SDECI=0
S @SDECY@(SDECI)="T00030IEN^T00030NAME^T00030SYNONYM"_$C(30)
S SDI="GMRCURGENCY" F S SDI=$O(^ORD(101,"B",SDI)) Q:$P(SDI," ",1)'="GMRCURGENCY" Q:SDI="" D
.S SDJ="" F S SDJ=$O(^ORD(101,"B",SDI,SDJ)) Q:SDJ="" D
..S SDNAME=$$GET1^DIQ(101,SDJ_",",.01)
..S SDSYN=""
..S SDK=0 F S SDK=$O(^ORD(101,SDJ,2,SDK)) Q:SDK'>0 D
...S SDSYN=SDSYN_$S(SDSYN'="":"|",1:"")_$$GET1^DIQ(101.02,SDK_","_SDJ_",",.01)
..S SDECI=SDECI+1
..S @SDECY@(SDECI)=SDJ_U_SDNAME_U_SDSYN_$C(30)
S @SDECY@(SDECI)=@SDECY@(SDECI)_$C(31)
Q
;
CONSULT(RET,MAXREC,DFN,SDBEG,SDEND,CLINIC,PRI,SCVISIT,SVCR,ORIGDT,DESDT,DESDTR,PRIGRP,SORT,PTS,SDMAX,URG,SDSVC,SDLASTC,ORIGDTR,SDCNT,MGIENS,SDALL) ;REQUEST/CONSULTATION
N LOOP,CLIEN,OSPEND,SDSTOP
Q:$G(SVCR)'="" ;only SD WAIT LIST and SDEC APPT REQUEST have this value - SERVICE RELATED
;Q:+$G(CLINIC)
S SCVISIT=$G(SCVISIT)
S SDSVC=$G(SDSVC)
S SDMAX=$G(SDMAX,200) ;S SDMAX=$S(+SDMAX>100:100,+SDMAX:SDMAX,1:50)
S SDSTOP=+$D(SORT("B","CTOPD"))
S SDBEG=$G(SDBEG) S:SDBEG="" SDBEG=1410102
S SDEND=$G(SDEND) S:SDEND="" SDEND=$S(DFN'="":4141015,1:$$FMADD^XLFDT($$NOW^XLFDT,-90))
I $D(SDALL("C")) D CDTRALL Q
I +DFN D CDFN Q
;I DESDT'="" D CDTR Q
;I DESDTR'="" D CDTR1 Q
I ORIGDT'="" D COR Q
I +SDSVC D SVC Q ;alb/sat 658 - use C xref for service filter
I +CLINIC D Q
.S LOOP="" F S LOOP=$O(CLINIC(LOOP)) Q:LOOP="" D
..S CLIEN=LOOP
..D CSDCL
D CDTR
Q
SVC ;look up REQUEST/CONSULTATION by service (CLINIC STOP) ;alb/sat 658
N DRQ,GMRSVC,SDGMR,STAT,SVC
D GETSVC^SDECGMR(.GMRSVC,.SDSVC)
;new uses AE xref
S SVC=0 F S SVC=$O(GMRSVC(SVC)) Q:SVC="" D SVC1 Q:SDCNT'<SDMAX
Q
SVC1 ;lookup 1 service
N OSACT,OSPEND,STAT
S OSACT=$O(^ORD(100.01,"B","ACTIVE",0))
S OSPEND=$O(^ORD(100.01,"B","PENDING",0))
F STAT=OSACT,OSPEND D Q:SDCNT'<SDMAX
.Q:STAT=""
.S DRQ=9999999-SDEND-1 F S DRQ=$O(^GMR(123,"AE",SVC,STAT,DRQ)) Q:DRQ="" Q:$P(DRQ,".",1)'<(9999999-SDBEG) D Q:SDCNT'<SDMAX
..S SDGMR=0 F S SDGMR=$O(^GMR(123,"AE",SVC,STAT,DRQ,SDGMR)) Q:SDGMR="" D CGET1 Q:SDCNT'<SDMAX
Q
SVC1R ;lookup 1 service reverse lookup
N OSACT,OSPEND,STAT
S OSACT=$O(^ORD(100.01,"B","ACTIVE",0))
S OSPEND=$O(^ORD(100.01,"B","PENDING",0))
F STAT=OSACT,OSPEND D Q:SDCNT'<SDMAX
.Q:STAT=""
.S DRQ=SDEND+1 F S DRQ=$O(^GMR(123,"AE",SVC,STAT,DRQ),-1) Q:DRQ="" Q:$P(DRQ,".",1)<SDBEG D Q:SDCNT'<SDMAX
..S SDGMR=999999999 F S SDGMR=$O(^GMR(123,"AE",SVC,STAT,DRQ,SDGMR),-1) Q:SDGMR="" D CGET1 Q:SDCNT'<SDMAX
Q
COR ;look up REQUEST/CONSULTATION by file entry date
N SDGMR,SDI,SDJ
N %DT,X,Y
S SDI="" F S SDI=$O(ORIGDT(SDI)) Q:SDI="" D
.S SDJ=SDI
.F S SDJ=$O(^GMR(123,"B",SDJ)) Q:SDJ'>0 Q:$P(SDJ,".",1)'=SDI D Q:SDCNT'<SDMAX
..I 'SDSTOP S SDGMR=0 F S SDGMR=$O(^GMR(123,"B",SDJ,SDGMR)) Q:SDGMR'>0 D CGET1 Q:SDCNT'<SDMAX
..I +SDSTOP S SDGMR=999999999 F S SDGMR=$O(^GMR(123,"B",SDJ,SDGMR),-1) Q:SDGMR'>0 D CGET1 Q:SDCNT'<SDMAX
Q
CSDCL ;look up REQUEST/CONSULTATION by clinic
N SDGMR,SDJ,SDJ1
N %DT,X,Y
I 'SDSTOP S SDGMR=0 F S SDGMR=$O(^GMR(123,"H",CLIEN,SDGMR)) Q:SDGMR'>0 D CGET1 Q:SDCNT'<SDMAX ;ICR 6185
I +SDSTOP S SDGMR=999999999 F S SDGMR=$O(^GMR(123,"H",CLIEN,SDGMR),-1) Q:SDGMR'>0 D CGET1 Q:SDCNT'<SDMAX
Q
CDTR ;look up REQUEST/CONSULTATION by date of request (desired date or date range)
N SDBEGI,SDENDI,SDGMR,SDJ,SDJ1,SD90
N %DT,X,Y
S SD90=$$FMADD^XLFDT($P($$NOW^XLFDT,".",1),-90)
S SDCNT=$G(SDCNT,0)
S SVC=0 F S SVC=$O(^GMR(123,"AE",SVC)) Q:SVC="" D SVC1:'SDSTOP,SVC1R:+SDSTOP Q:SDCNT'<SDMAX ;alb/sat 658 - use AE xref instead of AG
Q
CDTR1 ;look up REQUEST/CONSULTATION by date of request (desired date or date range) ;alb/sat 658 - this appears to not be used
Q
N SDBEGI,SDENDI,SDGMR,SDJ,SDJ1
N %DT,X,Y
S SDJ=$P(DESDTR,"~",1)-1
S SDJ1=$P(DESDTR,"~",2)
F S SDJ=$O(^GMR(123,"AG",SDJ)) Q:SDJ'>0 Q:SDJ>SDJ1 D Q:SDCNT'<SDMAX
.S SDGMR=0 F S SDGMR=$O(^GMR(123,"AG",SDJ,SDGMR)) Q:SDGMR'>0 D CGET1 Q:SDCNT'<SDMAX
Q
CDTRALL ;look up REQUEST/CONSULTATION by date of request (desired date or date range)
N SDBEGI,SDCNT,SDENDI,SDGMR,SDJ
N %DT,X,Y
S SDCNT=$G(SDCNT,0)
S SVC=0 F S SVC=$O(^GMR(123,"AE",SVC)) Q:SVC="" D SVC1:'SDSTOP,SVC1R:+SDSTOP ;alb/sat 658 - use AE instead of AG
Q
CDFN ;look up REQUEST/CONSULTATION by patient
N SDBEGI,SDENDI,SDGMR,SDJ,SDJ1
N %DT,X,Y
S SDBEGI=9999999-SDBEG
S SDENDI=9999999-SDEND
I 'SDSTOP D
.S (SDJ,SDJ1)=$S(DESDT'="":9999999-$P(DESDT,".",1),1:SDENDI)-1
.F S SDJ=$O(^GMR(123,"AD",DFN,SDJ)) Q:SDJ'>0 Q:SDJ>SDBEGI D Q:SDCNT'<SDMAX
..S SDGMR=0 F S SDGMR=$O(^GMR(123,"AD",DFN,SDJ,SDGMR)) Q:SDGMR'>0 D CGET1 Q:SDCNT'<SDMAX
I +SDSTOP D
.S (SDJ,SDJ1)=$S(DESDT'="":9999999-$P(DESDT,".",1)+1,1:SDBEGI)
.F S SDJ=$O(^GMR(123,"AD",DFN,SDJ),-1) Q:SDJ'>0 Q:(DESDT'="")&($P(SDJ,".",1)'=SDJ1) Q:SDJ<SDENDI D Q:SDCNT'<SDMAX
..S SDGMR=999999999 F S SDGMR=$O(^GMR(123,"AD",DFN,SDJ,SDGMR),-1) Q:SDGMR'>0 D CGET1 Q:SDCNT'<SDMAX
Q
CGET1 ;
N SDECY,Y,SDR,SDR2,SDR8,CLGP,PGRP,IEN,PT,SORTSTR,TYP,ODTE,DDTE,WAITD,SVPC,SVCPINV,ORIGGP,DESGP,SCPRI,SDR9,SVCP
N %DT,DOR,GMRSTOP,SDEDT,SDI,SDSVCF,SDSVCN,SVCREL,X ;alb/sat 651 - add %DT and X
S SDSVCF=0
D GETONE^SDEC(.SDECY,SDGMR)
S SDR=$G(@SDECY@(1))
S SDR=$P(SDR,$C(30))
S TYP="C"
I SDR="" Q
Q:$$REQCHK^SDEC51(,SDGMR)
S X=$P(SDR,U,2) S %DT="T" D ^%DT Q:Y=-1 ;alb/jsm 658 - removed Q:$$FMADD^XLFDT(DT,-365)>Y ;alb/sat 651 - do not return entries older than 365 days
I +URG I '$D(URG(+$P(SDR,U,43))) Q
S SDR2=$P($P(SDR,U,2),".",1) ; S %DT="" S X=$P(SDR2,"@",1) D ^%DT S SDR2=$P(Y,".",1)
S SDR9=$P($P(SDR,U,9),".",1) ; S %DT="" S X=$P(SDR8,"@",1) D ^%DT S SDR8=$P(Y,".",1)
S PGRP=$P(SDR,U,24)
S PT=$P(SDR,U,3) ;Patient
I PTS'="",PT'="",$D(PTS(PT))=0 Q
I PGRP="" S PGRP="GROUP 0"
I PRIGRP'="",$D(PRI(PGRP))=0 Q ;No match on priority group
S CLGP=$P(SDR,U,6)
I +$G(CLINIC),$D(CLINIC(+CLGP))=0 Q ;match clinic
S DESGP=$P(SDR,U,9)
S SDEDT=$P(SDR,U,2) I SDEDT'="",($P(SDEDT,".",1)>$P(SDEND,".",1))!($P(SDEDT,".",1)<$P(SDBEG,".",1)) Q ;alb/sat 658 - use file entry date instead of earliest date
;I DESDT'="",DESGP'="",$D(DESDT(DESGP))=0 Q ;match date of request with desired date
I DESDTR'="",'$$INRANGE(SDEDT,$P(DESDTR,"~",1),$P(DESDTR,"~",2)) Q ; (SDEDT'>SDR8<SDBEG)!(SDR8>SDEND) G CGET1X ;check date range of earliest date
I +DESDT,$D(DESDT(+SDEDT))=0 Q ;match EARLIEST DATE with desired date
S ORIGGP=$P(SDR,U,2)
I SDEDT="",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($P(ORIGGP,".",1)))=0 Q ;match origination date with file entry date
I SCVISIT'="",SCVISIT'="BOTH" Q:(SCVISIT="NO")&($P(SDR,U,27)="") Q:SCVISIT'=$P(SDR,U,27) ;SCVisit for filter (patient)
;I +SDSVC N SDSVCN S SDSVCN=$$GET1^DIQ(44,+$P(SDR,U,6)_",",8,"E") Q:SDSVCN="" Q:'$D(SDSVC(SDSVCN)) ;check service
I +SDSVC D Q:'SDSVCF
.D STOP^SDECGMR(.GMRSTOP,SDGMR)
.S SDI=0 F S SDI=$O(GMRSTOP(SDI)) Q:SDI="" D Q:SDSVCF=1
..S SDSVCN=GMRSTOP(SDI)
..S:$D(SDSVC(SDSVCN)) SDSVCF=1
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^SDECRMG1($P(SDR,U,2)))
S IEN=$P(SDR,U,1)
S SVCP=$P(SDR,U,28)
S SVCPINV=100-SVCP
;S ODTE=$$INVDT^SDECRMG1($P(SDR2,"."))
S ODTE=$P(SDR2,".")
S DDTE=$TR($P(SDR9,"-",2)," ","")
S WAITD=9999999-WAITD
S SORTSTR=$$SORT^SDECRMG1(.SORT,IEN,WAITD,TYP,PT,SVCPINV,PGRP,CLGP,SDEDT,ODTE,SCPRI,,SVCREL) ;alb/sat 658 - add SVCREL
D SETNODE^SDECRMG1(WAITD,TYP,IEN,SDR,42,SORTSTR,.SDCNT)
;S SDCNT=SDCNT+1
Q
CGET1X ;
K @SDECY
Q
;
INRANGE(CHK,BEG,END) ;
; return 1 if CHK is within BEG and END inclusive
; return 0 if not
Q:CHK="" 0
Q:CHK<BEG 0
Q:CHK>END 0
Q 1
;
MGIENS(MGIENS,MAXREC,DFN,SDBEG,SDEND,CLINIC,PRI,SCVISIT,SVCR,ORIGDT,DESDT,DESDTR,PRIGRP,SORT,PTS,SDMAX,URG,SDSVC,SDLASTA,ORIGDTR,SDCNT,MRTC) ;get specified IENs and sort to the top alb/jsm added MRTC
; MGIENS("A123")=""
N SDI,SIEN,STYP
S SDI="" F S SDI=$O(MGIENS(SDI)) Q:SDI="" D
.S STYP=$E(SDI,1)
.S SIEN=$E(SDI,2,$L(SDI))
.D @STYP
Q
A ;
N NOD,RET
D ARGET^SDEC(.RET,SIEN)
S NOD=@RET@(1) D APPT1^SDECRMG1(MAXREC,DFN,SDBEG,SDEND,.CLINIC,.PRI,SCVISIT,SVCR,.ORIGDT,.DESDT,DESDTR,PRIGRP,.SORT,.PTS,SDMAX,.URG,.SDSVC,.SDLASTA,.ORIGDTR,.SDCNT,NOD,.MGIENS,.MRTC) ;alb/jsm added MRTC
Q
C ;
Q
E ;
N NOD,RET
D WLGET^SDEC(.RET,SIEN)
S NOD=@RET@(1) D WAIT1^SDECRMG1(MAXREC,DFN,SDBEG,SDEND,.CLINIC,.PRI,SCVISIT,SVCR,.ORIGDT,.DESDT,DESDTR,PRIGRP,.SORT,.PTS,SDMAX,.URG,.SDSVC,.SDLASTA,.ORIGDTR,.SDCNT,NOD,.MGIENS)
Q
R ;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDECRMG2 9740 printed Apr 09, 2024@21:57:27 Page 2
SDECRMG2 ;ALB/SAT/JSM - VISTA SCHEDULING RPCS ;MAR 15, 2017
+1 ;;5.3;Scheduling;**627,642,651,658**;Aug 13, 1993;Build 23
+2 ;
+3 ;Reference is made to ICR #6185
+4 QUIT
+5 ;
URGENCY(SDECY) ;GET valid urgency protocol values that are used in the URGENCY field 5 of the REQUEST CONSULTAION file 123
+1 ;INPUT: none
+2 ;RETURN:
+3 ; Global array in which each entry contains the IEN and NAME of a protocol entry
+4 ; 1. IEN - pointer to PROTOCOL file 101
+5 ; 2. NAME - name field from PROTOCOL file
+6 ; 3. SYNONYM - Short name list separated by pipe.
+7 ; Synonym that might be what is recognized by the users
+8 NEW SDECI,SDI,SDID,SDJ,SDK,SDNAME,SDSYN
+9 SET SDECY="^TMP(""SDECRMG2"","_$JOB_",""URGENCY"")"
+10 KILL @SDECY
+11 SET SDECI=0
+12 SET @SDECY@(SDECI)="T00030IEN^T00030NAME^T00030SYNONYM"_$CHAR(30)
+13 SET SDI="GMRCURGENCY"
FOR
SET SDI=$ORDER(^ORD(101,"B",SDI))
if $PIECE(SDI," ",1)'="GMRCURGENCY"
QUIT
if SDI=""
QUIT
Begin DoDot:1
+14 SET SDJ=""
FOR
SET SDJ=$ORDER(^ORD(101,"B",SDI,SDJ))
if SDJ=""
QUIT
Begin DoDot:2
+15 SET SDNAME=$$GET1^DIQ(101,SDJ_",",.01)
+16 SET SDSYN=""
+17 SET SDK=0
FOR
SET SDK=$ORDER(^ORD(101,SDJ,2,SDK))
if SDK'>0
QUIT
Begin DoDot:3
+18 SET SDSYN=SDSYN_$SELECT(SDSYN'="":"|",1:"")_$$GET1^DIQ(101.02,SDK_","_SDJ_",",.01)
End DoDot:3
+19 SET SDECI=SDECI+1
+20 SET @SDECY@(SDECI)=SDJ_U_SDNAME_U_SDSYN_$CHAR(30)
End DoDot:2
End DoDot:1
+21 SET @SDECY@(SDECI)=@SDECY@(SDECI)_$CHAR(31)
+22 QUIT
+23 ;
CONSULT(RET,MAXREC,DFN,SDBEG,SDEND,CLINIC,PRI,SCVISIT,SVCR,ORIGDT,DESDT,DESDTR,PRIGRP,SORT,PTS,SDMAX,URG,SDSVC,SDLASTC,ORIGDTR,SDCNT,MGIENS,SDALL) ;REQUEST/CONSULTATION
+1 NEW LOOP,CLIEN,OSPEND,SDSTOP
+2 ;only SD WAIT LIST and SDEC APPT REQUEST have this value - SERVICE RELATED
if $GET(SVCR)'=""
QUIT
+3 ;Q:+$G(CLINIC)
+4 SET SCVISIT=$GET(SCVISIT)
+5 SET SDSVC=$GET(SDSVC)
+6 ;S SDMAX=$S(+SDMAX>100:100,+SDMAX:SDMAX,1:50)
SET SDMAX=$GET(SDMAX,200)
+7 SET SDSTOP=+$DATA(SORT("B","CTOPD"))
+8 SET SDBEG=$GET(SDBEG)
if SDBEG=""
SET SDBEG=1410102
+9 SET SDEND=$GET(SDEND)
if SDEND=""
SET SDEND=$SELECT(DFN'="":4141015,1:$$FMADD^XLFDT($$NOW^XLFDT,-90))
+10 IF $DATA(SDALL("C"))
DO CDTRALL
QUIT
+11 IF +DFN
DO CDFN
QUIT
+12 ;I DESDT'="" D CDTR Q
+13 ;I DESDTR'="" D CDTR1 Q
+14 IF ORIGDT'=""
DO COR
QUIT
+15 ;alb/sat 658 - use C xref for service filter
IF +SDSVC
DO SVC
QUIT
+16 IF +CLINIC
Begin DoDot:1
+17 SET LOOP=""
FOR
SET LOOP=$ORDER(CLINIC(LOOP))
if LOOP=""
QUIT
Begin DoDot:2
+18 SET CLIEN=LOOP
+19 DO CSDCL
End DoDot:2
End DoDot:1
QUIT
+20 DO CDTR
+21 QUIT
SVC ;look up REQUEST/CONSULTATION by service (CLINIC STOP) ;alb/sat 658
+1 NEW DRQ,GMRSVC,SDGMR,STAT,SVC
+2 DO GETSVC^SDECGMR(.GMRSVC,.SDSVC)
+3 ;new uses AE xref
+4 SET SVC=0
FOR
SET SVC=$ORDER(GMRSVC(SVC))
if SVC=""
QUIT
DO SVC1
if SDCNT'<SDMAX
QUIT
+5 QUIT
SVC1 ;lookup 1 service
+1 NEW OSACT,OSPEND,STAT
+2 SET OSACT=$ORDER(^ORD(100.01,"B","ACTIVE",0))
+3 SET OSPEND=$ORDER(^ORD(100.01,"B","PENDING",0))
+4 FOR STAT=OSACT,OSPEND
Begin DoDot:1
+5 if STAT=""
QUIT
+6 SET DRQ=9999999-SDEND-1
FOR
SET DRQ=$ORDER(^GMR(123,"AE",SVC,STAT,DRQ))
if DRQ=""
QUIT
if $PIECE(DRQ,".",1)'<(9999999-SDBEG)
QUIT
Begin DoDot:2
+7 SET SDGMR=0
FOR
SET SDGMR=$ORDER(^GMR(123,"AE",SVC,STAT,DRQ,SDGMR))
if SDGMR=""
QUIT
DO CGET1
if SDCNT'<SDMAX
QUIT
End DoDot:2
if SDCNT'<SDMAX
QUIT
End DoDot:1
if SDCNT'<SDMAX
QUIT
+8 QUIT
SVC1R ;lookup 1 service reverse lookup
+1 NEW OSACT,OSPEND,STAT
+2 SET OSACT=$ORDER(^ORD(100.01,"B","ACTIVE",0))
+3 SET OSPEND=$ORDER(^ORD(100.01,"B","PENDING",0))
+4 FOR STAT=OSACT,OSPEND
Begin DoDot:1
+5 if STAT=""
QUIT
+6 SET DRQ=SDEND+1
FOR
SET DRQ=$ORDER(^GMR(123,"AE",SVC,STAT,DRQ),-1)
if DRQ=""
QUIT
if $PIECE(DRQ,".",1)<SDBEG
QUIT
Begin DoDot:2
+7 SET SDGMR=999999999
FOR
SET SDGMR=$ORDER(^GMR(123,"AE",SVC,STAT,DRQ,SDGMR),-1)
if SDGMR=""
QUIT
DO CGET1
if SDCNT'<SDMAX
QUIT
End DoDot:2
if SDCNT'<SDMAX
QUIT
End DoDot:1
if SDCNT'<SDMAX
QUIT
+8 QUIT
COR ;look up REQUEST/CONSULTATION by file entry date
+1 NEW SDGMR,SDI,SDJ
+2 NEW %DT,X,Y
+3 SET SDI=""
FOR
SET SDI=$ORDER(ORIGDT(SDI))
if SDI=""
QUIT
Begin DoDot:1
+4 SET SDJ=SDI
+5 FOR
SET SDJ=$ORDER(^GMR(123,"B",SDJ))
if SDJ'>0
QUIT
if $PIECE(SDJ,".",1)'=SDI
QUIT
Begin DoDot:2
+6 IF 'SDSTOP
SET SDGMR=0
FOR
SET SDGMR=$ORDER(^GMR(123,"B",SDJ,SDGMR))
if SDGMR'>0
QUIT
DO CGET1
if SDCNT'<SDMAX
QUIT
+7 IF +SDSTOP
SET SDGMR=999999999
FOR
SET SDGMR=$ORDER(^GMR(123,"B",SDJ,SDGMR),-1)
if SDGMR'>0
QUIT
DO CGET1
if SDCNT'<SDMAX
QUIT
End DoDot:2
if SDCNT'<SDMAX
QUIT
End DoDot:1
+8 QUIT
CSDCL ;look up REQUEST/CONSULTATION by clinic
+1 NEW SDGMR,SDJ,SDJ1
+2 NEW %DT,X,Y
+3 ;ICR 6185
IF 'SDSTOP
SET SDGMR=0
FOR
SET SDGMR=$ORDER(^GMR(123,"H",CLIEN,SDGMR))
if SDGMR'>0
QUIT
DO CGET1
if SDCNT'<SDMAX
QUIT
+4 IF +SDSTOP
SET SDGMR=999999999
FOR
SET SDGMR=$ORDER(^GMR(123,"H",CLIEN,SDGMR),-1)
if SDGMR'>0
QUIT
DO CGET1
if SDCNT'<SDMAX
QUIT
+5 QUIT
CDTR ;look up REQUEST/CONSULTATION by date of request (desired date or date range)
+1 NEW SDBEGI,SDENDI,SDGMR,SDJ,SDJ1,SD90
+2 NEW %DT,X,Y
+3 SET SD90=$$FMADD^XLFDT($PIECE($$NOW^XLFDT,".",1),-90)
+4 SET SDCNT=$GET(SDCNT,0)
+5 ;alb/sat 658 - use AE xref instead of AG
SET SVC=0
FOR
SET SVC=$ORDER(^GMR(123,"AE",SVC))
if SVC=""
QUIT
if 'SDSTOP
DO SVC1
if +SDSTOP
DO SVC1R
if SDCNT'<SDMAX
QUIT
+6 QUIT
CDTR1 ;look up REQUEST/CONSULTATION by date of request (desired date or date range) ;alb/sat 658 - this appears to not be used
+1 QUIT
+2 NEW SDBEGI,SDENDI,SDGMR,SDJ,SDJ1
+3 NEW %DT,X,Y
+4 SET SDJ=$PIECE(DESDTR,"~",1)-1
+5 SET SDJ1=$PIECE(DESDTR,"~",2)
+6 FOR
SET SDJ=$ORDER(^GMR(123,"AG",SDJ))
if SDJ'>0
QUIT
if SDJ>SDJ1
QUIT
Begin DoDot:1
+7 SET SDGMR=0
FOR
SET SDGMR=$ORDER(^GMR(123,"AG",SDJ,SDGMR))
if SDGMR'>0
QUIT
DO CGET1
if SDCNT'<SDMAX
QUIT
End DoDot:1
if SDCNT'<SDMAX
QUIT
+8 QUIT
CDTRALL ;look up REQUEST/CONSULTATION by date of request (desired date or date range)
+1 NEW SDBEGI,SDCNT,SDENDI,SDGMR,SDJ
+2 NEW %DT,X,Y
+3 SET SDCNT=$GET(SDCNT,0)
+4 ;alb/sat 658 - use AE instead of AG
SET SVC=0
FOR
SET SVC=$ORDER(^GMR(123,"AE",SVC))
if SVC=""
QUIT
if 'SDSTOP
DO SVC1
if +SDSTOP
DO SVC1R
+5 QUIT
CDFN ;look up REQUEST/CONSULTATION by patient
+1 NEW SDBEGI,SDENDI,SDGMR,SDJ,SDJ1
+2 NEW %DT,X,Y
+3 SET SDBEGI=9999999-SDBEG
+4 SET SDENDI=9999999-SDEND
+5 IF 'SDSTOP
Begin DoDot:1
+6 SET (SDJ,SDJ1)=$SELECT(DESDT'="":9999999-$PIECE(DESDT,".",1),1:SDENDI)-1
+7 FOR
SET SDJ=$ORDER(^GMR(123,"AD",DFN,SDJ))
if SDJ'>0
QUIT
if SDJ>SDBEGI
QUIT
Begin DoDot:2
+8 SET SDGMR=0
FOR
SET SDGMR=$ORDER(^GMR(123,"AD",DFN,SDJ,SDGMR))
if SDGMR'>0
QUIT
DO CGET1
if SDCNT'<SDMAX
QUIT
End DoDot:2
if SDCNT'<SDMAX
QUIT
End DoDot:1
+9 IF +SDSTOP
Begin DoDot:1
+10 SET (SDJ,SDJ1)=$SELECT(DESDT'="":9999999-$PIECE(DESDT,".",1)+1,1:SDBEGI)
+11 FOR
SET SDJ=$ORDER(^GMR(123,"AD",DFN,SDJ),-1)
if SDJ'>0
QUIT
if (DESDT'="")&($PIECE(SDJ,".",1)'=SDJ1)
QUIT
if SDJ<SDENDI
QUIT
Begin DoDot:2
+12 SET SDGMR=999999999
FOR
SET SDGMR=$ORDER(^GMR(123,"AD",DFN,SDJ,SDGMR),-1)
if SDGMR'>0
QUIT
DO CGET1
if SDCNT'<SDMAX
QUIT
End DoDot:2
if SDCNT'<SDMAX
QUIT
End DoDot:1
+13 QUIT
CGET1 ;
+1 NEW SDECY,Y,SDR,SDR2,SDR8,CLGP,PGRP,IEN,PT,SORTSTR,TYP,ODTE,DDTE,WAITD,SVPC,SVCPINV,ORIGGP,DESGP,SCPRI,SDR9,SVCP
+2 ;alb/sat 651 - add %DT and X
NEW %DT,DOR,GMRSTOP,SDEDT,SDI,SDSVCF,SDSVCN,SVCREL,X
+3 SET SDSVCF=0
+4 DO GETONE^SDEC(.SDECY,SDGMR)
+5 SET SDR=$GET(@SDECY@(1))
+6 SET SDR=$PIECE(SDR,$CHAR(30))
+7 SET TYP="C"
+8 IF SDR=""
QUIT
+9 if $$REQCHK^SDEC51(,SDGMR)
QUIT
+10 ;alb/jsm 658 - removed Q:$$FMADD^XLFDT(DT,-365)>Y ;alb/sat 651 - do not return entries older than 365 days
SET X=$PIECE(SDR,U,2)
SET %DT="T"
DO ^%DT
if Y=-1
QUIT
+11 IF +URG
IF '$DATA(URG(+$PIECE(SDR,U,43)))
QUIT
+12 ; S %DT="" S X=$P(SDR2,"@",1) D ^%DT S SDR2=$P(Y,".",1)
SET SDR2=$PIECE($PIECE(SDR,U,2),".",1)
+13 ; S %DT="" S X=$P(SDR8,"@",1) D ^%DT S SDR8=$P(Y,".",1)
SET SDR9=$PIECE($PIECE(SDR,U,9),".",1)
+14 SET PGRP=$PIECE(SDR,U,24)
+15 ;Patient
SET PT=$PIECE(SDR,U,3)
+16 IF PTS'=""
IF PT'=""
IF $DATA(PTS(PT))=0
QUIT
+17 IF PGRP=""
SET PGRP="GROUP 0"
+18 ;No match on priority group
IF PRIGRP'=""
IF $DATA(PRI(PGRP))=0
QUIT
+19 SET CLGP=$PIECE(SDR,U,6)
+20 ;match clinic
IF +$GET(CLINIC)
IF $DATA(CLINIC(+CLGP))=0
QUIT
+21 SET DESGP=$PIECE(SDR,U,9)
+22 ;alb/sat 658 - use file entry date instead of earliest date
SET SDEDT=$PIECE(SDR,U,2)
IF SDEDT'=""
IF ($PIECE(SDEDT,".",1)>$PIECE(SDEND,".",1))!($PIECE(SDEDT,".",1)<$PIECE(SDBEG,".",1))
QUIT
+23 ;I DESDT'="",DESGP'="",$D(DESDT(DESGP))=0 Q ;match date of request with desired date
+24 ; (SDEDT'>SDR8<SDBEG)!(SDR8>SDEND) G CGET1X ;check date range of earliest date
IF DESDTR'=""
IF '$$INRANGE(SDEDT,$PIECE(DESDTR,"~",1),$PIECE(DESDTR,"~",2))
QUIT
+25 ;match EARLIEST DATE with desired date
IF +DESDT
IF $DATA(DESDT(+SDEDT))=0
QUIT
+26 SET ORIGGP=$PIECE(SDR,U,2)
+27 IF SDEDT=""
IF ORIGGP'=""
IF (ORIGGP>SDEND)!(ORIGGP<SDBEG)
QUIT
+28 ;match origination date range with file entry date
IF ORIGDTR'=""
IF ORIGGP'=""
IF (ORIGGP<$PIECE(ORIGDTR,"~",1))!(ORIGGP>$PIECE(ORIGDTR,"~",2))
QUIT
+29 ;match origination date with file entry date
IF ORIGDT'=""
IF ORIGGP'=""
IF $DATA(ORIGDT($PIECE(ORIGGP,".",1)))=0
QUIT
+30 ;SCVisit for filter (patient)
IF SCVISIT'=""
IF SCVISIT'="BOTH"
if (SCVISIT="NO")&($PIECE(SDR,U,27)="")
QUIT
if SCVISIT'=$PIECE(SDR,U,27)
QUIT
+31 ;I +SDSVC N SDSVCN S SDSVCN=$$GET1^DIQ(44,+$P(SDR,U,6)_",",8,"E") Q:SDSVCN="" Q:'$D(SDSVC(SDSVCN)) ;check service
+32 IF +SDSVC
Begin DoDot:1
+33 DO STOP^SDECGMR(.GMRSTOP,SDGMR)
+34 SET SDI=0
FOR
SET SDI=$ORDER(GMRSTOP(SDI))
if SDI=""
QUIT
Begin DoDot:2
+35 SET SDSVCN=GMRSTOP(SDI)
+36 if $DATA(SDSVC(SDSVCN))
SET SDSVCF=1
End DoDot:2
if SDSVCF=1
QUIT
End DoDot:1
if 'SDSVCF
QUIT
+37 ;SCVisit for sorting
SET SCPRI=0
+38 ;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:"")
+39 SET WAITD=$$FMDIFF^XLFDT($PIECE($$NOW^XLFDT,".",1),$$CVTDT^SDECRMG1($PIECE(SDR,U,2)))
+40 SET IEN=$PIECE(SDR,U,1)
+41 SET SVCP=$PIECE(SDR,U,28)
+42 SET SVCPINV=100-SVCP
+43 ;S ODTE=$$INVDT^SDECRMG1($P(SDR2,"."))
+44 SET ODTE=$PIECE(SDR2,".")
+45 SET DDTE=$TRANSLATE($PIECE(SDR9,"-",2)," ","")
+46 SET WAITD=9999999-WAITD
+47 ;alb/sat 658 - add SVCREL
SET SORTSTR=$$SORT^SDECRMG1(.SORT,IEN,WAITD,TYP,PT,SVCPINV,PGRP,CLGP,SDEDT,ODTE,SCPRI,,SVCREL)
+48 DO SETNODE^SDECRMG1(WAITD,TYP,IEN,SDR,42,SORTSTR,.SDCNT)
+49 ;S SDCNT=SDCNT+1
+50 QUIT
CGET1X ;
+1 KILL @SDECY
+2 QUIT
+3 ;
INRANGE(CHK,BEG,END) ;
+1 ; return 1 if CHK is within BEG and END inclusive
+2 ; return 0 if not
+3 if CHK=""
QUIT 0
+4 if CHK<BEG
QUIT 0
+5 if CHK>END
QUIT 0
+6 QUIT 1
+7 ;
MGIENS(MGIENS,MAXREC,DFN,SDBEG,SDEND,CLINIC,PRI,SCVISIT,SVCR,ORIGDT,DESDT,DESDTR,PRIGRP,SORT,PTS,SDMAX,URG,SDSVC,SDLASTA,ORIGDTR,SDCNT,MRTC) ;get specified IENs and sort to the top alb/jsm added MRTC
+1 ; MGIENS("A123")=""
+2 NEW SDI,SIEN,STYP
+3 SET SDI=""
FOR
SET SDI=$ORDER(MGIENS(SDI))
if SDI=""
QUIT
Begin DoDot:1
+4 SET STYP=$EXTRACT(SDI,1)
+5 SET SIEN=$EXTRACT(SDI,2,$LENGTH(SDI))
+6 DO @STYP
End DoDot:1
+7 QUIT
A ;
+1 NEW NOD,RET
+2 DO ARGET^SDEC(.RET,SIEN)
+3 ;alb/jsm added MRTC
SET NOD=@RET@(1)
DO APPT1^SDECRMG1(MAXREC,DFN,SDBEG,SDEND,.CLINIC,.PRI,SCVISIT,SVCR,.ORIGDT,.DESDT,DESDTR,PRIGRP,.SORT,.PTS,SDMAX,.URG,.SDSVC,.SDLASTA,.ORIGDTR,.SDCNT,NOD,.MGIENS,.MRTC)
+4 QUIT
C ;
+1 QUIT
E ;
+1 NEW NOD,RET
+2 DO WLGET^SDEC(.RET,SIEN)
+3 SET NOD=@RET@(1)
DO WAIT1^SDECRMG1(MAXREC,DFN,SDBEG,SDEND,.CLINIC,.PRI,SCVISIT,SVCR,.ORIGDT,.DESDT,DESDTR,PRIGRP,.SORT,.PTS,SDMAX,.URG,.SDSVC,.SDLASTA,.ORIGDTR,.SDCNT,NOD,.MGIENS)
+4 QUIT
R ;
+1 QUIT
