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