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

SDECRMG2.m

Go to the documentation of this file. 
  1. SDECRMG2 ;ALB/SAT/JSM - VISTA SCHEDULING RPCS ;MAR 15, 2017
  1.  ;;5.3;Scheduling;**627,642,651,658**;Aug 13, 1993;Build 23
  1.  ;
  1.  ;Reference is made to ICR #6185
  1.  Q
  1.  ;
  1. URGENCY(SDECY) ;GET valid urgency protocol values that are used in the URGENCY field 5 of the REQUEST CONSULTAION file 123
  1.  ;INPUT: none
  1.  ;RETURN:
  1.  ; Global array in which each entry contains the IEN and NAME of a protocol entry
  1.  ;    1. IEN     - pointer to PROTOCOL file 101
  1.  ;    2. NAME    - name field from PROTOCOL file
  1.  ;    3. SYNONYM - Short name list separated by pipe.
  1.  ;                 Synonym that might be what is recognized by the users
  1.  N SDECI,SDI,SDID,SDJ,SDK,SDNAME,SDSYN
  1.  S SDECY="^TMP(""SDECRMG2"","_$J_",""URGENCY"")"
  1.  K @SDECY
  1.  S SDECI=0
  1.  S @SDECY@(SDECI)="T00030IEN^T00030NAME^T00030SYNONYM"_$C(30)
  1.  S SDI="GMRCURGENCY" F  S SDI=$O(^ORD(101,"B",SDI)) Q:$P(SDI," ",1)'="GMRCURGENCY"  Q:SDI=""  D
  1.  .S SDJ="" F  S SDJ=$O(^ORD(101,"B",SDI,SDJ)) Q:SDJ=""  D
  1.  ..S SDNAME=$$GET1^DIQ(101,SDJ_",",.01)
  1.  ..S SDSYN=""
  1.  ..S SDK=0 F  S SDK=$O(^ORD(101,SDJ,2,SDK)) Q:SDK'>0  D
  1.  ...S SDSYN=SDSYN_$S(SDSYN'="":"|",1:"")_$$GET1^DIQ(101.02,SDK_","_SDJ_",",.01)
  1.  ..S SDECI=SDECI+1
  1.  ..S @SDECY@(SDECI)=SDJ_U_SDNAME_U_SDSYN_$C(30)
  1.  S @SDECY@(SDECI)=@SDECY@(SDECI)_$C(31)
  1.  Q
  1.  ;
  1. 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.  N LOOP,CLIEN,OSPEND,SDSTOP
  1.  Q:$G(SVCR)'=""   ;only SD WAIT LIST and SDEC APPT REQUEST have this value - SERVICE RELATED
  1.  ;Q:+$G(CLINIC)
  1.  S SCVISIT=$G(SCVISIT)
  1.  S SDSVC=$G(SDSVC)
  1.  S SDMAX=$G(SDMAX,200)   ;S SDMAX=$S(+SDMAX>100:100,+SDMAX:SDMAX,1:50)
  1.  S SDSTOP=+$D(SORT("B","CTOPD"))
  1.  S SDBEG=$G(SDBEG) S:SDBEG="" SDBEG=1410102
  1.  S SDEND=$G(SDEND) S:SDEND="" SDEND=$S(DFN'="":4141015,1:$$FMADD^XLFDT($$NOW^XLFDT,-90))
  1.  I $D(SDALL("C")) D CDTRALL Q
  1.  I +DFN D CDFN Q
  1.  ;I DESDT'="" D CDTR Q
  1.  ;I DESDTR'="" D CDTR1 Q
  1.  I ORIGDT'="" D COR Q
  1.  I +SDSVC D SVC Q   ;alb/sat 658 - use C xref for service filter
  1.  I +CLINIC D  Q
  1.  .S LOOP="" F  S LOOP=$O(CLINIC(LOOP)) Q:LOOP=""  D
  1.  ..S CLIEN=LOOP
  1.  ..D CSDCL
  1.  D CDTR
  1.  Q
  1. SVC ;look up REQUEST/CONSULTATION by service (CLINIC STOP)  ;alb/sat 658
  1.  N DRQ,GMRSVC,SDGMR,STAT,SVC
  1.  D GETSVC^SDECGMR(.GMRSVC,.SDSVC)
  1.  ;new uses AE xref
  1.  S SVC=0 F  S SVC=$O(GMRSVC(SVC)) Q:SVC=""  D SVC1 Q:SDCNT'<SDMAX
  1.  Q
  1. SVC1 ;lookup 1 service
  1.  N OSACT,OSPEND,STAT
  1.  S OSACT=$O(^ORD(100.01,"B","ACTIVE",0))
  1.  S OSPEND=$O(^ORD(100.01,"B","PENDING",0))
  1.  F STAT=OSACT,OSPEND D  Q:SDCNT'<SDMAX
  1.  .Q:STAT=""
  1.  .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
  1.  ..S SDGMR=0 F  S SDGMR=$O(^GMR(123,"AE",SVC,STAT,DRQ,SDGMR)) Q:SDGMR=""  D CGET1 Q:SDCNT'<SDMAX
  1.  Q
  1. SVC1R ;lookup 1 service reverse lookup
  1.  N OSACT,OSPEND,STAT
  1.  S OSACT=$O(^ORD(100.01,"B","ACTIVE",0))
  1.  S OSPEND=$O(^ORD(100.01,"B","PENDING",0))
  1.  F STAT=OSACT,OSPEND D  Q:SDCNT'<SDMAX
  1.  .Q:STAT=""
  1.  .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
  1.  ..S SDGMR=999999999 F  S SDGMR=$O(^GMR(123,"AE",SVC,STAT,DRQ,SDGMR),-1) Q:SDGMR=""  D CGET1 Q:SDCNT'<SDMAX
  1.  Q
  1. COR ;look up REQUEST/CONSULTATION by file entry date
  1.  N SDGMR,SDI,SDJ
  1.  N %DT,X,Y
  1.  S SDI="" F  S SDI=$O(ORIGDT(SDI)) Q:SDI=""  D
  1.  .S SDJ=SDI
  1.  .F  S SDJ=$O(^GMR(123,"B",SDJ)) Q:SDJ'>0  Q:$P(SDJ,".",1)'=SDI  D  Q:SDCNT'<SDMAX
  1.  ..I 'SDSTOP S SDGMR=0 F  S SDGMR=$O(^GMR(123,"B",SDJ,SDGMR)) Q:SDGMR'>0  D CGET1 Q:SDCNT'<SDMAX
  1.  ..I +SDSTOP S SDGMR=999999999 F  S SDGMR=$O(^GMR(123,"B",SDJ,SDGMR),-1) Q:SDGMR'>0  D CGET1 Q:SDCNT'<SDMAX
  1.  Q
  1. CSDCL ;look up REQUEST/CONSULTATION by clinic
  1.  N SDGMR,SDJ,SDJ1
  1.  N %DT,X,Y
  1.  I 'SDSTOP S SDGMR=0 F  S SDGMR=$O(^GMR(123,"H",CLIEN,SDGMR)) Q:SDGMR'>0  D CGET1 Q:SDCNT'<SDMAX    ;ICR 6185
  1.  I +SDSTOP S SDGMR=999999999 F  S SDGMR=$O(^GMR(123,"H",CLIEN,SDGMR),-1) Q:SDGMR'>0  D CGET1 Q:SDCNT'<SDMAX
  1.  Q
  1. CDTR ;look up REQUEST/CONSULTATION by date of request (desired date or date range)
  1.  N SDBEGI,SDENDI,SDGMR,SDJ,SDJ1,SD90
  1.  N %DT,X,Y
  1.  S SD90=$$FMADD^XLFDT($P($$NOW^XLFDT,".",1),-90)
  1.  S SDCNT=$G(SDCNT,0)
  1.  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
  1.  Q
  1. CDTR1 ;look up REQUEST/CONSULTATION by date of request (desired date or date range)  ;alb/sat 658 - this appears to not be used
  1.  Q
  1.  N SDBEGI,SDENDI,SDGMR,SDJ,SDJ1
  1.  N %DT,X,Y
  1.  S SDJ=$P(DESDTR,"~",1)-1
  1.  S SDJ1=$P(DESDTR,"~",2)
  1.  F  S SDJ=$O(^GMR(123,"AG",SDJ)) Q:SDJ'>0  Q:SDJ>SDJ1  D  Q:SDCNT'<SDMAX
  1.  .S SDGMR=0 F  S SDGMR=$O(^GMR(123,"AG",SDJ,SDGMR)) Q:SDGMR'>0  D CGET1 Q:SDCNT'<SDMAX
  1.  Q
  1. CDTRALL ;look up REQUEST/CONSULTATION by date of request (desired date or date range)
  1.  N SDBEGI,SDCNT,SDENDI,SDGMR,SDJ
  1.  N %DT,X,Y
  1.  S SDCNT=$G(SDCNT,0)
  1.  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
  1.  Q
  1. CDFN ;look up REQUEST/CONSULTATION by patient
  1.  N SDBEGI,SDENDI,SDGMR,SDJ,SDJ1
  1.  N %DT,X,Y
  1.  S SDBEGI=9999999-SDBEG
  1.  S SDENDI=9999999-SDEND
  1.  I 'SDSTOP D
  1.  .S (SDJ,SDJ1)=$S(DESDT'="":9999999-$P(DESDT,".",1),1:SDENDI)-1
  1.  .F  S SDJ=$O(^GMR(123,"AD",DFN,SDJ)) Q:SDJ'>0  Q:SDJ>SDBEGI  D  Q:SDCNT'<SDMAX
  1.  ..S SDGMR=0 F  S SDGMR=$O(^GMR(123,"AD",DFN,SDJ,SDGMR)) Q:SDGMR'>0  D CGET1 Q:SDCNT'<SDMAX
  1.  I +SDSTOP D
  1.  .S (SDJ,SDJ1)=$S(DESDT'="":9999999-$P(DESDT,".",1)+1,1:SDBEGI)
  1.  .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
  1.  ..S SDGMR=999999999 F  S SDGMR=$O(^GMR(123,"AD",DFN,SDJ,SDGMR),-1) Q:SDGMR'>0  D CGET1 Q:SDCNT'<SDMAX
  1.  Q
  1. CGET1 ;
  1.  N SDECY,Y,SDR,SDR2,SDR8,CLGP,PGRP,IEN,PT,SORTSTR,TYP,ODTE,DDTE,WAITD,SVPC,SVCPINV,ORIGGP,DESGP,SCPRI,SDR9,SVCP
  1.  N %DT,DOR,GMRSTOP,SDEDT,SDI,SDSVCF,SDSVCN,SVCREL,X  ;alb/sat 651 - add %DT and X
  1.  S SDSVCF=0
  1.  D GETONE^SDEC(.SDECY,SDGMR)
  1.  S SDR=$G(@SDECY@(1))
  1.  S SDR=$P(SDR,$C(30))
  1.  S TYP="C"
  1.  I SDR="" Q
  1.  Q:$$REQCHK^SDEC51(,SDGMR)
  1.  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
  1.  I +URG I '$D(URG(+$P(SDR,U,43))) Q
  1.  S SDR2=$P($P(SDR,U,2),".",1)   ; S %DT="" S X=$P(SDR2,"@",1) D ^%DT S SDR2=$P(Y,".",1)
  1.  S SDR9=$P($P(SDR,U,9),".",1)   ; S %DT="" S X=$P(SDR8,"@",1) D ^%DT S SDR8=$P(Y,".",1)
  1.  S PGRP=$P(SDR,U,24)
  1.  S PT=$P(SDR,U,3)                           ;Patient
  1.  I PTS'="",PT'="",$D(PTS(PT))=0 Q
  1.  I PGRP="" S PGRP="GROUP 0"
  1.  I PRIGRP'="",$D(PRI(PGRP))=0 Q             ;No match on priority group
  1.  S CLGP=$P(SDR,U,6)
  1.  I +$G(CLINIC),$D(CLINIC(+CLGP))=0 Q    ;match clinic
  1.  S DESGP=$P(SDR,U,9)
  1.  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
  1.  ;I DESDT'="",DESGP'="",$D(DESDT(DESGP))=0 Q      ;match date of request with desired date
  1.  I DESDTR'="",'$$INRANGE(SDEDT,$P(DESDTR,"~",1),$P(DESDTR,"~",2))  Q  ;   (SDEDT'>SDR8<SDBEG)!(SDR8>SDEND) G CGET1X      ;check date range of earliest date
  1.  I +DESDT,$D(DESDT(+SDEDT))=0 Q   ;match EARLIEST DATE with desired date
  1.  S ORIGGP=$P(SDR,U,2)
  1.  I SDEDT="",ORIGGP'="",(ORIGGP>SDEND)!(ORIGGP<SDBEG) Q
  1.  I ORIGDTR'="",ORIGGP'="",(ORIGGP<$P(ORIGDTR,"~",1))!(ORIGGP>$P(ORIGDTR,"~",2)) Q  ;match origination date range with file entry date
  1.  I ORIGDT'="",ORIGGP'="",$D(ORIGDT($P(ORIGGP,".",1)))=0 Q  ;match origination date with file entry date
  1.  I SCVISIT'="",SCVISIT'="BOTH" Q:(SCVISIT="NO")&($P(SDR,U,27)="")  Q:SCVISIT'=$P(SDR,U,27)           ;SCVisit for filter (patient)
  1.  ;I +SDSVC N SDSVCN S SDSVCN=$$GET1^DIQ(44,+$P(SDR,U,6)_",",8,"E") Q:SDSVCN=""  Q:'$D(SDSVC(SDSVCN))   ;check service
  1.  I +SDSVC D  Q:'SDSVCF
  1.  .D STOP^SDECGMR(.GMRSTOP,SDGMR)
  1.  .S SDI=0 F  S SDI=$O(GMRSTOP(SDI)) Q:SDI=""  D  Q:SDSVCF=1
  1.  ..S SDSVCN=GMRSTOP(SDI)
  1.  ..S:$D(SDSVC(SDSVCN)) SDSVCF=1
  1.  S SCPRI=0                               ;SCVisit for sorting
  1.  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.
  1.  S WAITD=$$FMDIFF^XLFDT($P($$NOW^XLFDT,".",1),$$CVTDT^SDECRMG1($P(SDR,U,2)))
  1.  S IEN=$P(SDR,U,1)
  1.  S SVCP=$P(SDR,U,28)
  1.  S SVCPINV=100-SVCP
  1.  ;S ODTE=$$INVDT^SDECRMG1($P(SDR2,"."))
  1.  S ODTE=$P(SDR2,".")
  1.  S DDTE=$TR($P(SDR9,"-",2)," ","")
  1.  S WAITD=9999999-WAITD
  1.  S SORTSTR=$$SORT^SDECRMG1(.SORT,IEN,WAITD,TYP,PT,SVCPINV,PGRP,CLGP,SDEDT,ODTE,SCPRI,,SVCREL)  ;alb/sat 658 - add SVCREL
  1.  D SETNODE^SDECRMG1(WAITD,TYP,IEN,SDR,42,SORTSTR,.SDCNT)
  1.  ;S SDCNT=SDCNT+1
  1.  Q
  1. CGET1X ;
  1.  K @SDECY
  1.  Q
  1.  ;
  1. INRANGE(CHK,BEG,END)  ;
  1.  ; return 1 if CHK is within BEG and END inclusive
  1.  ; return 0 if not
  1.  Q:CHK="" 0
  1.  Q:CHK<BEG 0
  1.  Q:CHK>END 0
  1.  Q 1
  1.  ;
  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
  1.  ;  MGIENS("A123")=""
  1.  N SDI,SIEN,STYP
  1.  S SDI="" F  S SDI=$O(MGIENS(SDI)) Q:SDI=""  D
  1.  .S STYP=$E(SDI,1)
  1.  .S SIEN=$E(SDI,2,$L(SDI))
  1.  .D @STYP
  1.  Q
  1. A ;
  1.  N NOD,RET
  1.  D ARGET^SDEC(.RET,SIEN)
  1.  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
  1.  Q
  1. C ;
  1.  Q
  1. E ;
  1.  N NOD,RET
  1.  D WLGET^SDEC(.RET,SIEN)
  1.  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)
  1.  Q
  1. R ;
  1.  Q