Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SDEC51

SDEC51.m

Go to the documentation of this file.
SDEC51 ;ALB/SAT,CT,LAB - VISTA SCHEDULING RPCS ;JUN 12, 2020@12:15
 ;;5.3;Scheduling;**627,642,651,658,686,745,756**;Aug 13, 1993;Build 43
 ;
 ;Reference is made to ICR's #4837, #4557, #6185, and #6186
 Q
 ;
REQGET(SDECY,SDBEG,SDEND,MAXREC,LASTSUB,SDGMR) ; GET entries that are not SCHEDULED.
REQGETA ;
 N PADDRES1,PADDRES2,PADDRES3,PCITY,PSTATE,PCOUNTRY,PTPHONE,PZIP4
 N SDECI,SDI,SDJ,SDREASON,SDREC,SDRECL,SDRPA,SDRPA0,SDTMP,SDWP,X,Y,%DT
 N SDCNT,SDCAN,SDCDC,SDCANF,SDCSTOP,SDSCHED,SDSCHEDF,SDSENS,SDSTAT,SDSTATF,SDDONE
 N DIC,ELIGIEN,ELIGNAME,GAF,PRIGRP,SVCCONN,SVCCONNP,TYPEIEN,TYPENAME
 N SDDEMO,SDNOCHK,SDSUB
 N DOB,GENDER,HRN,INSTIEN,INSTNAME,NAME,SSN,SVVCCONN
 S (SDNOCHK,SDSUB)=""
 S SDECI=0
 K ^TMP("SDEC",$J)
 S SDECY="^TMP(""SDEC"","_$J_")"
 ; data header
 D HDR
 S (SDCANF,SDSCHEDF)=0
 S SDREC=$$GETIEN("RECEIVED")
 I SDREC="" D ERR1^SDECERR(-1,"REQUEST ACTION TYPES file does not have an entry of RECEIVED.",.SDECI,SDECY) Q
 S SDSCHED=$$GETIEN("SCHEDULED")
 I SDSCHED="" D ERR1^SDECERR(-1,"REQUEST ACTION TYPES file does not have an entry of SCHEDULED.",.SDECI,SDECY) Q
 S SDSTAT=$$GETIEN("STATUS CHANGE")
 S SDCAN=$$GETIEN("CANCELLED")
 S SDDONE=$$GETIEN("COMPLETE/UPDATE")
 S SDCDC=$$GETIEN("DISCONTINUED")
 ;validate SDBEG (optional)
 S SDBEG=$G(SDBEG)
 I $G(SDBEG)'="" S %DT="" S X=$P($G(SDBEG),"@",1) D ^%DT S SDBEG=Y I Y=-1 S SDBEG=$$FMADD^XLFDT($P($$NOW^XLFDT,".",1),-1825)
 I $G(SDBEG)="" S SDBEG=$$FMADD^XLFDT($P($$NOW^XLFDT,".",1),-1825)
 ;validate SDEND (optional)
 S SDEND=$G(SDEND)
 I SDEND'="" S %DT="" S X=$P($G(SDEND),"@",1) D ^%DT S SDEND=Y I Y=-1 S SDEND=$$FMADD^XLFDT($P($$NOW^XLFDT,".",1),-90)
 I SDEND="" S SDEND=$$FMADD^XLFDT($P($$NOW^XLFDT,".",1),-90)
 ;validate SDGMR (optional)
 S SDGMR=$G(SDGMR)
 I SDGMR'="" I '$D(^GMR(123,+SDGMR,0)) D ERR1^SDECERR(-1,"Invalid Request/Consultation ID.",.SDECI,SDECY) Q   ;ICR 4837
 I SDGMR'="" S SDNOCHK=1 D REQGET1 G REQX
 ;validate MAXREC (optional)
 S MAXREC=+$G(MAXREC)
 I 'MAXREC S MAXREC=9999999
 ;validate LASTSUB (optional)
 S LASTSUB=$G(LASTSUB)
 S SDCNT=0
 S SDJ=$S($P(LASTSUB,"|",1)'="":$P(LASTSUB,"|",1),1:(SDBEG-1)_".2359")
 ;alb/sat 658 - default lookup uses AE instead of AG
 N SDJ,SDJ1,SD90,SVC
 N %DT,X,Y
 N DRQ,OSACT,OSPEND,SDGMR,STAT
 S OSACT=$O(^ORD(100.01,"B","ACTIVE",0))
 S OSPEND=$O(^ORD(100.01,"B","PENDING",0))
 S SDECI=$G(SDECI,0)
 S SVC=$S($P(LASTSUB,"|",1)'="":$P(LASTSUB,"|",1)-1,1:0)
 F  S SVC=$O(^GMR(123,"AE",SVC)) Q:SVC=""  D  Q:SDECI>(MAXREC-1)
 .F STAT=OSACT,OSPEND D  Q:SDECI>(MAXREC-1)
 ..Q:STAT=""
 ..Q:($P(LASTSUB,"|",2)'="")&($P(LASTSUB,"|",2)'=STAT)
 ..S DRQ=$S($P(LASTSUB,"|",3)'="":$P(LASTSUB,"|",3)-.0001,1:SDBEG-1)
 ..F  S DRQ=$O(^GMR(123,"AE",SVC,STAT,DRQ)) Q:DRQ=""  Q:$P(DRQ,".",1)>SDEND  D  Q:SDECI>(MAXREC-1)
 ...S SDGMR=$S($P(LASTSUB,"|",4)'="":$P(LASTSUB,"|",4),1:0)
 ...S LASTSUB=""
 ...F  S SDGMR=$O(^GMR(123,"AE",SVC,STAT,DRQ,SDGMR)) Q:SDGMR=""  D REQGET1 I SDECI>(MAXREC-1) S SDSUB=SVC_"|"_STAT_"|"_DRQ_"|"_SDGMR Q
REQX ;
 S SDTMP=@SDECY@(SDECI) S SDTMP=$P(SDTMP,$C(30),1)
 S:$G(SDSUB)'="" $P(SDTMP,U,40)=SDSUB
 S @SDECY@(SDECI)=SDTMP_$C(30,31)
 Q
HDR ;Get the header information
 ;              1                 2           3         4
 S SDTMP="T00020CONSULTIEN^T00020ORIGDT^T00020DFN^T00030NAME"
 ;                     5                6             7              8                     9
 S SDTMP=SDTMP_"^T00030TO_SERVICE^T00010CLINIEN^T00030CLINNAME^T00030DATE_OF_REQUEST^T00030PRIO"
 ;                     10            11             12            13
 S SDTMP=SDTMP_"^T00030USERIEN^T00030USERNAME^T00030PROVIEN^T00030PROVNAME"
 ;                     14                 15                        16         17
 S SDTMP=SDTMP_"^T00030REQUEST_TYPE^T00030SERVICE_RENDERED_AS^T00100COMM^T00500REQ_PROC_ACT"
 ;                     18        19        20        21           22            23
 S SDTMP=SDTMP_"^T00030HRN^T00030DOB^T00030SSN^T00030GENDER^T00030INSTIEN^T00030INSTNAME"
 ;                     24           25            26             27            28
 S SDTMP=SDTMP_"^T00030PRIGRP^T00030ELIGIEN^T00030ELIGNAME^T00030SVCCONN^T00030SVCCONNP"
 ;                     29            30             31             32             33
 S SDTMP=SDTMP_"^T00030TYPEIEN^T00030TYPENAME^T00030PADDRES1^T00030PADDRES2^T00030PADDRES3"
 ;                     34          35           36             37          38      39             40
 S SDTMP=SDTMP_"^T00030PCITY^T00030PSTATE^T00030PCOUNTRY^T00030PZIP4^T00030GAF^T00100SENSITIVE^T00030LASTSUB"
 ;                     41         42            43            44          45           46         47
 S SDTMP=SDTMP_"^T00100STOP^T00030PTPHONE^T00030URGENCY^T00030PRACE^T00030PRACEN^T00030PETH^T00030PETHN"
 ;                     48            49
 S SDTMP=SDTMP_"^T00030PRHBLOC^T00030EARLIEST"
 S SDTMP=SDTMP_"^T00030BADADD^T00030OPHONE^T00030NOK^T00030KNAME^T00030KREL^T00030KPHONE"   ;55
 S SDTMP=SDTMP_"^T00030KSTREET^T00030KSTREET2^T00030KSTREET3^T00030KCITY^T00030KSTATE^T00030KZIP"   ;61
 S SDTMP=SDTMP_"^T00030NOK2^T00030K2NAME^T00030K2REL^T00030K2PHONE"  ;65
 S SDTMP=SDTMP_"^T00030K2STREET^T00030K2STREET2^T00030K2STREET3^T00030K2CITY^T00030K2STATE^T00030K2ZIP^T00030PCOUNTY"  ;72
 S SDTMP=SDTMP_"^T00030PMARITAL^T00030PRELIGION"  ;74
 S SDTMP=SDTMP_"^T00030PTACTIVE^T00030PTADDRESS1^T00030PTADDRESS2PTADDRESS3^T00030^T00030PTCITY^T00030PTSTATE^T00030PTZIP^T00030PTZIP+4"  ;82
 S SDTMP=SDTMP_"^T00030PTCOUNTRY^T00030PTCOUNTY^T00030PTPHONE^T00030PTSTART^T00030PTEND^T00030PCELL^T00030PPAGER^T00030PEMAIL"  ;90
 S SDTMP=SDTMP_"^T00030PF_FFF^T00030PF_VCD^T00030PFNATIONAL^T00030PFLOCAL^T00030SUBGRP^T00030CAT8G^T01000SIMILAR"  ;97
 S SDTMP=SDTMP_"^T00030CPHONE^T00030CLET"  ;99  added call phone & letter  *745  5/14/2020
 S SDTMP=SDTMP_"^T00030COVID_PRIORITY" ;*756
 S @SDECY@(SDECI)=SDTMP_$C(30)
 Q
GETONE(SDECY,SDGMR) ;Get one specific consult
 ;              1                 2           3         4
 N PADDRES1,PADDRES2,PADDRES3,PCITY,PSTATE,PCOUNTRY,PZIP4
 N SDECI,SDI,SDJ,SDREASON,SDREC,SDRECL,SDRPA,SDRPA0,SDTMP,SDWP,X,Y,%DT
 N SDCNT,SDCAN,SDCDC,SDCANF,SDCSTOP,SDSCHED,SDSCHEDF,SDSENS,SDSTAT,SDSTATF,SDDONE
 N ELIGIEN,ELIGNAME,GAF,PRIGRP,SVCCONN,SVCCONNP,TYPEIEN,TYPENAME
 N SDDEMO,SDSUB,SDCON
 N DOB,GENDER,HRN,INSTIEN,INSTNAME,NAME,SSN,SVVCCONN
 N PRACE,PRACEN,PETH,PETHN,CLIEN,CLNAME
 S SDSUB=""
 S SDECI=0
 K ^TMP("SDEC",$J)
 S SDECY="^TMP(""SDEC"","_$J_")"
 D HDR
 S (SDCANF,SDSCHEDF)=0
 S SDREC=$$GETIEN("RECEIVED")
 I SDREC="" D ERR1^SDECERR(-1,"REQUEST ACTION TYPES file does not have an entry of RECEIVED.",.SDECI,SDECY) Q
 S SDSCHED=$$GETIEN("SCHEDULED")
 I SDSCHED="" D ERR1^SDECERR(-1,"REQUEST ACTION TYPES file does not have an entry of SCHEDULED.",.SDECI,SDECY) Q
 S SDSTAT=$$GETIEN("STATUS CHANGE")
 S SDCAN=$$GETIEN("CANCELLED")
 S SDDONE=$$GETIEN("COMPLETE/UPDATE")
 S SDCDC=$$GETIEN("DISCONTINUED")
 D REQGET1
 Q
REQGET1 ;
 N SDCL,SDGMR0,SDDATA,SDSER,SDSTOP,SIEN,STOP,IN,PRHBLOC
 ;
 ;  Added DFN to new list so data error in file #123 does not cause GUI to crash.  wtc  SD*5.3*686
 ;
 N PRIO,DFN ;
 S SDRECL="",SDSTOP=""
 S (SDCANF,SDSCHEDF,SDSTATF)=0
 S SDCL=$P($G(^GMR(123,+SDGMR,0)),U,6)   ;ICR 4837
 I SDCL'="",$$GET1^DIQ(44,SDCL_",",50.01,"I")=1 Q  ;check OOS?
 S PRHBLOC=$S($$GET1^DIQ(44,+SDCL_",",2500,"I")="Y":1,1:0)
 S SDGMR0=$G(^GMR(123,SDGMR,0))   ;ICR 4837 states 'Zero node read into variable'
 S IN=$P(SDGMR0,U,18)   ;$$GET1^DIQ(123,SDGMR_",",14)
 ;Q:IN="inpatient"            ;Inpatient consults do not have appointments
 S SDSER=$P(SDGMR0,U,5)
 I +SDSER D
 .S SIEN=0 F  S SIEN=$O(^GMR(123.5,SDSER,688,SIEN)) Q:'+SIEN  D
 ..S STOP=$G(^GMR(123.5,SDSER,688,SIEN,0))   ;ICR 4557
 ..I SDSTOP="" S SDSTOP=STOP
 ..E  S SDSTOP=SDSTOP_"|"_STOP
 S DFN=$$GET1^DIQ(123,SDGMR_",",.02,"I")
 Q:DFN=""
 ;
 I '$G(SDNOCHK) Q:$$REQCHK(.SDRECL,SDGMR,DFN)
 ;
 ;Q:SDCANF
 ;Q:SDSCHEDF
 I 1 D
 .;get REASON FOR REQUEST wp text
 .K SDWP
 .S X=$$GET1^DIQ(123,SDGMR_",",20,"","SDWP")
 .;S SDREASON=""
 .;I $D(SDWP) S SDI="" F  S SDI=$O(SDWP(SDI)) Q:SDI=""  S SDREASON=$S(SDREASON'="":SDREASON_$C(13,10),1:"")_$TR(SDWP(SDI),"^") Q
 .;collect demographics
 .D PDEMO^SDECU3(.SDDEMO,DFN)   ;alb/sat 658 PDEMO moved to SDECU3
 .S NAME=SDDEMO("NAME")
 .S DOB=SDDEMO("DOB")
 .S GENDER=SDDEMO("GENDER")
 .S HRN=SDDEMO("HRN")
 .S SSN=SDDEMO("SSN")
 .S INSTIEN=SDDEMO("INSTIEN")
 .S INSTNAME=SDDEMO("INSTNAME")
 .S PRIGRP=SDDEMO("PRIGRP")       ;24
 .S ELIGIEN=SDDEMO("ELIGIEN")     ;25
 .S ELIGNAME=SDDEMO("ELIGNAME")   ;26
 .S SVVCCONN=SDDEMO("SVCCONN")    ;27
 .S SVCCONNP=SDDEMO("SVCCONNP")   ;28
 .S TYPEIEN=SDDEMO("TYPEIEN")     ;29
 .S TYPENAME=SDDEMO("TYPENAME")   ;30
 .S PADDRES1=SDDEMO("PADDRES1")   ;31   - Patient Address line 1
 .S PADDRES2=SDDEMO("PADDRES2")   ;32   - Patient Address line 2
 .S PADDRES3=SDDEMO("PADDRES3")   ;33   - Patient Address line 3
 .S PCITY=SDDEMO("PCITY")         ;34   - Patient City
 .S PSTATE=SDDEMO("PSTATE")       ;35   - Patient state name
 .S PCOUNTRY=SDDEMO("PCOUNTRY")   ;36   - Patient country name
 .S PZIP4=SDDEMO("PZIP+4")        ;37   - Patient Zip+4
 .S PTPHONE=SDDEMO("HPHONE")      ;42   - Patient phone
 .S GAF=$$GAF^SDECU2(DFN)         ;38
 .S SDSENS=$$PTSEC^SDECUTL(DFN)   ;39
 .;*745 lab- Changing the clinic ien and name to check for field .05 needed for IFCs.
 .S CLIEN=$$GET1^DIQ(123,SDGMR_",",2,"I") S:CLIEN="" CLIEN=$$GET1^DIQ(123,SDGMR_",",.05,"I")
 .S CLNAME=$$GET1^DIQ(123,SDGMR_",",2) S:CLNAME="" CLNAME=$$GET1^DIQ(123,SDGMR_",",.05)
 .D RACELST^SDECU2(DFN,.PRACE,.PRACEN)
 .D ETH^SDECU2(DFN,.PETH,.PETHN)   ;get ethnicity
 .S PRIO=$$PRIO^SDEC51A(SDGMR)
 .;       1         2                                     3                  4
 .S SDTMP=SDGMR_"^"_$$GET1^DIQ(123,SDGMR_",",.01,"I")_"^"_$P(SDGMR0,U,2)_"^"_$$GET1^DIQ(123,SDGMR_",",.02)
 .;                 5                               6                                   7                               8
 .S SDTMP=SDTMP_"^"_$$GET1^DIQ(123,SDGMR_",",1)_"^"_CLIEN_"^"_CLNAME_"^"_$$GET1^DIQ(123,SDGMR_",",3,"I") ;*745 - lab- changes to clinic name for IFCs
 .;                 9        10                                  11                              12
 .S SDTMP=SDTMP_"^"_PRIO_"^"_$$GET1^DIQ(123,SDGMR_",",7,"I")_"^"_$$GET1^DIQ(123,SDGMR_",",7)_"^"_$P(SDGMR0,U,14)
 .;                 13                               14                               15
 .S SDTMP=SDTMP_"^"_$$GET1^DIQ(123,SDGMR_",",10)_"^"_$$GET1^DIQ(123,SDGMR_",",13)_"^"_$$GET1^DIQ(123,SDGMR_",",14)
 .;                 16     17
 .S SDTMP=SDTMP_"^"_""_"^"_SDRECL
 .;               18   19    20    21       22        23
 .S SDTMP=SDTMP_U_""_U_DOB_U_SSN_U_GENDER_U_INSTIEN_U_INSTNAME    ;23
 .;               24       25        26         27         28
 .S SDTMP=SDTMP_U_PRIGRP_U_ELIGIEN_U_ELIGNAME_U_SVVCCONN_U_SVCCONNP   ;28
 .;               29        30         31         32         33
 .S SDTMP=SDTMP_U_TYPEIEN_U_TYPENAME_U_PADDRES1_U_PADDRES2_U_PADDRES3 ;33
 .;               34      35       36         37      38      39
 .S SDTMP=SDTMP_U_PCITY_U_PSTATE_U_PCOUNTRY_U_PZIP4_U_GAF_U_SDSENS    ;39
 .S SDTMP=SDTMP_U_U_SDSTOP_U_PTPHONE_U_$$GET1^DIQ(123,SDGMR_",",5,"I")  ;save the 40th position for LASTSUB if it is to be returned
 .S SDTMP=SDTMP_U_PRACE_U_PRACEN_U_PETH_U_PETHN_U_PRHBLOC_U_$$GET1^DIQ(123,SDGMR_",",17,"I")   ;49
 .S $P(SDTMP,U,50)=SDDEMO("BADADD")
 .S $P(SDTMP,U,51)=SDDEMO("OPHONE")
 .S $P(SDTMP,U,52)=SDDEMO("NOK")
 .S $P(SDTMP,U,53)=SDDEMO("KNAME")
 .S $P(SDTMP,U,54)=SDDEMO("KREL")
 .S $P(SDTMP,U,55)=SDDEMO("KPHONE")
 .S $P(SDTMP,U,56)=SDDEMO("KSTREET")
 .S $P(SDTMP,U,57)=SDDEMO("KSTREET2")
 .S $P(SDTMP,U,58)=SDDEMO("KSTREET3")
 .S $P(SDTMP,U,59)=SDDEMO("KCITY")
 .S $P(SDTMP,U,60)=SDDEMO("KSTATE")
 .S $P(SDTMP,U,61)=SDDEMO("KZIP")
 .S $P(SDTMP,U,62)=SDDEMO("NOK2")
 .S $P(SDTMP,U,63)=SDDEMO("K2NAME")
 .S $P(SDTMP,U,64)=SDDEMO("K2REL")
 .S $P(SDTMP,U,65)=SDDEMO("K2PHONE")
 .S $P(SDTMP,U,66)=SDDEMO("K2STREET")
 .S $P(SDTMP,U,67)=SDDEMO("K2STREET2")
 .S $P(SDTMP,U,68)=SDDEMO("K2STREET3")
 .S $P(SDTMP,U,69)=SDDEMO("K2CITY")
 .S $P(SDTMP,U,70)=SDDEMO("K2STATE")
 .S $P(SDTMP,U,71)=SDDEMO("K2ZIP")
 .S $P(SDTMP,U,72)=SDDEMO("PCOUNTY")
 .S $P(SDTMP,U,73)=SDDEMO("PMARITAL")
 .S $P(SDTMP,U,74)=SDDEMO("PRELIGION")
 .S $P(SDTMP,U,75)=SDDEMO("PTACTIVE")
 .S $P(SDTMP,U,76)=SDDEMO("PTADDRESS1")
 .S $P(SDTMP,U,77)=SDDEMO("PTADDRESS2")
 .S $P(SDTMP,U,78)=SDDEMO("PTADDRESS3")
 .S $P(SDTMP,U,79)=SDDEMO("PTCITY")
 .S $P(SDTMP,U,80)=SDDEMO("PTSTATE")
 .S $P(SDTMP,U,81)=SDDEMO("PTZIP")
 .S $P(SDTMP,U,82)=SDDEMO("PTZIP+4")
 .S $P(SDTMP,U,83)=SDDEMO("PTCOUNTRY")
 .S $P(SDTMP,U,84)=SDDEMO("PTCOUNTY")
 .S $P(SDTMP,U,85)=SDDEMO("PTPHONE")
 .S $P(SDTMP,U,86)=SDDEMO("PTSTART")
 .S $P(SDTMP,U,87)=SDDEMO("PTEND")
 .S $P(SDTMP,U,88)=SDDEMO("PCELL")
 .S $P(SDTMP,U,89)=SDDEMO("PPAGER")
 .S $P(SDTMP,U,90)=SDDEMO("PEMAIL")
 .S $P(SDTMP,U,91)=SDDEMO("PF_FFF")
 .S $P(SDTMP,U,92)=SDDEMO("PF_VCD")
 .S $P(SDTMP,U,93)=SDDEMO("PFNATIONAL")
 .S $P(SDTMP,U,94)=SDDEMO("PFLOCAL")
 .S $P(SDTMP,U,95)=SDDEMO("SUBGRP")
 .S $P(SDTMP,U,96)=(PRIGRP="GROUP 8")&(SDDEMO("SUBGRP")="g")
 .S $P(SDTMP,U,97)=SDDEMO("SIMILAR")
 .S SDCON=$$CALLCON^SDECAR1A(DFN,SDGMR)  ; SDECALL_U_SDECLET  # OF CALLS MADE^DATE LAST LETTER SENT  CT *745 5/12/2020
 .S $P(SDTMP,U,98)=$P(SDCON,U,1)      ; CT  *745  5/12/2020  SDCALL
 .S $P(SDTMP,U,99)=$P(SDCON,U,2)      ; CT  *745  5/12/2020  SDCLET
 .S $P(SDTMP,U,100)=$$PRIORITY(SDGMR) ;*756 find most recent covid-19 priority
 .S SDECI=SDECI+1 S @SDECY@(SDECI)=SDTMP_$C(30)
 Q
 ;
REQCHK(SDRECL,SDGMR,DFN) ;alb/sat 658 - new rules for consult check
 N CPRSTAT,IFC,OSACT,OSPEND
 Q:'$D(^GMR(123,+$G(SDGMR),0)) 1
 S OSACT=$O(^ORD(100.01,"B","ACTIVE",0))
 S OSPEND=$O(^ORD(100.01,"B","PENDING",0))
 S CPRSTAT=$$GET1^DIQ(123,SDGMR_",",8,"I")
 Q:'((CPRSTAT=OSACT)!(CPRSTAT=OSPEND)) 1
 S IFC=$$GET1^DIQ(123,SDGMR,.125,"I")
 Q:IFC="P" 1
 Q 0
REQCHK1(SDRECL,SDGMR,DFN) ; OLD
 N CPRSTAT,X,X1,X2   ;alb/sat 651
 N SDCAN,SDCANF,SDCDC,SDDONE,SDES,SDESF,SDFD,SDPDC,SDRPA,SDRPA0,SDSCHED,SDSCHEDF,SDSER,SDSTAT,SDSTATF
 N SDNOS     ;alb/sat 651
 S SDPDC=$O(^ORD(100.01,"B","DISCONTINUED",0))
 S CPRSTAT=$$GET1^DIQ(123,SDGMR_",",8,"I")   ;alb/sat 651 - set new CPRSTAT var
 Q:CPRSTAT=SDPDC 1   ;don't return this entry if CPRS STATUS is DISCONTINUED ;alb/sat 651 - use CPRSTAT instead of GET1^DIQ
 S SDFD=$P($$GET1^DIQ(123,SDGMR_",",.01,"I"),".",1)   ;alb/sat 651 - get FILE ENTRY DATE
 ;**Removed below line alb/jsm 658 - Consults to be displayed in the RM Grid regardless of the request date**
 ;Q:$$FMADD^XLFDT(DT,-365)>SDFD 1  ;alb/sat 651 - do not include records with FILE ENTRY DATE older than 1 year
 S SDSCHED=$$GETIEN("SCHEDULED")      ;$O(^GMR(123.1,"B","SCHEDULED",0))
 S SDSTAT=$$GETIEN("STATUS CHANGE")   ;$O(^GMR(123.1,"B","STATUS CHANGE",0))
 S SDCAN=$$GETIEN("CANCELLED")        ;$O(^GMR(123.1,"B","CANCELLED",0))
 S SDDONE=$$GETIEN("COMPLETE/UPDATE") ;$O(^GMR(123.1,"B","COMPLETE/UPDATE",0))
 S SDCDC=$$GETIEN("DISCONTINUED")     ;$O(^GMR(123.1,"B","DISCONTINUED",0))
 S SDES=$$GETIEN("EDIT/RESUBMITTED")
 S SDSER=$$GET1^DIQ(123,SDGMR_",",1,"I")   ;ICR 6185
 S DFN=$G(DFN) I '+DFN S DFN=$$GET1^DIQ(123,SDGMR_",",.02,"I")   ;ICR 6185
 S SDRECL=$G(SDRECL)
 S (SDCANF,SDESF,SDSCHEDF,SDSTATF)=0
 ;alb/sat 651 - start modification
 I CPRSTAT=13 D  G REQCHKX     ;cancel/no-show  ;13 is cancel - see A+7^SDCNSLT SD*5.3*627
 .S SDCANF=1
 .S SDNOS=$O(^GMR(123,SDGMR,40,":"),-1) Q:'+SDNOS       ;ICR 6185
 .S SDNOS=$O(^GMR(123,SDGMR,40,SDNOS),-1) Q:'+SDNOS
 .S X2=$P($G(^GMR(123,SDGMR,40,SDNOS,0)),U),X1=DT D ^%DTC Q:X'=""&(X>180)   ;ICR 6185
 .I $$FINDTXT^SDEC51A(SDGMR,SDNOS) D
 ..S SDCANF=0
 ..S:$L($G(SDRECL))<225 SDRECL=SDNOS_";;"_$$GET1^DIQ(123.02,SDNOS_","_SDGMR_",",.01,"E")_";;"_SDCAN_$S(SDRECL'="":"|"_SDRECL,1:"")
 ;alb/sat 651 - end modification
 S SDRPA=9999999 F  S SDRPA=$O(^GMR(123,SDGMR,40,SDRPA),-1) Q:SDRPA'>0  D  Q:SDCANF=1  Q:SDSCHEDF=1  Q:SDESF=1   ;ICR 6185
 .K SDDATA
 .D GETS^DIQ(123.02,SDRPA_","_SDGMR_",",".01;1;2;4","IE","SDDATA")   ;ICR 6185
 .S SDRPA0=SDDATA(123.02,SDRPA_","_SDGMR_",",1,"I")  ;  $G(^GMR(123,SDGMR,40,SDRPA,0))
 .I SDRPA0'=SDSCHED,SDRPA0'=SDSTAT,SDRPA0'=SDCAN,SDRPA0'=SDDONE,SDRPA0'=SDCDC,SDRPA0'=SDES Q  ;SDRECL is getting too long; only watch the ones we need
 .I (SDRPA0=SDCAN)!(SDRPA0=SDDONE)!(SDRPA0=SDCDC) S SDCANF=1 Q    ;skip completed consults/mgh
 .I SDRPA0=SDES S SDESF=1 Q
 .I SDRPA0=SDSCHED,SDSTATF'=1,$$SDCHED^SDEC51A(DFN,SDDATA(123.02,SDRPA_","_SDGMR_",",2,"I"),SDSER) S SDSCHEDF=1 Q
 .I SDRPA0=SDSTAT,$$FINDTXT^SDEC51A(SDGMR,SDRPA) S SDSTATF=1
 .S:$L($G(SDRECL))<225 SDRECL=SDRPA_";;"_SDDATA(123.02,SDRPA_","_SDGMR_",",.01,"E")_";;"_SDRPA0_$S(SDRECL'="":"|"_SDRECL,1:"")
REQCHKX ; exit  ;alb/sat 651 - add REQCHKX tag
 K SDDATA
 Q:SDSCHEDF SDSCHEDF
 Q:SDCANF SDCANF
 Q:SDESF 0
 Q 0
 ;
GETIEN(NAME) ;get ID from REQUEST ACTION TYPES file 123.1   ;ICR 6186
 N DIC
 S DIC=123.1
 S DIC(0)="BO"
 S X=NAME
 D ^DIC
 I Y=-1 Q ""
 Q $P(Y,U,1)
PRIORITY(GRMIEN) ;get priority from CONSULT activity (new tag *756)
 ;Input: GRMIEN = IEN of the REQUEST/CONSUTL (#123)
 ;returns: last priority entered into the consult activity
 ;
 N SDTOT,SDERR,SDACTDA,SDIDX,SDIDX2,SDPFND,PRITY
 S SDTOT=$P($G(^GMR(123,GRMIEN,40,0)),"^",4)
 ;
 ; get all activity for ien
 ;
 D GETS^DIQ(123,GRMIEN,"40*",,"SDACTDA","SDERR")
 ;
 ;loop through activity multiple in reverse order to find the most recently 
 ;added "-COVID-19 Priority"
 ;
 S SDPFND=0
 F SDIDX=SDTOT:-1:1 Q:SDPFND=1  D
 .S SDIDX2=""
 .F  S SDIDX2=$O(SDACTDA(123.02,SDIDX_","_GRMIEN_",",5,SDIDX2)) Q:(SDIDX2="")!(SDPFND)  D
 ..I $G(SDACTDA(123.02,SDIDX_","_GRMIEN_",",5,SDIDX2))["COVID-19 Priority" D
 ... S PRITY=$P($G(SDACTDA(123.02,SDIDX_","_GRMIEN_",",5,SDIDX2)),"-COVID-19 Priority",1)
 ... S PRITY=$E(PRITY,$L(PRITY)-2,$L(PRITY))
 ... S SDPFND=1
 Q $G(PRITY)