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

SDEC51A.m

Go to the documentation of this file. 
  1. SDEC51A ;ALB/SAT - VISTA SCHEDULING RPCS ;MAR 15, 2017
  1.  ;;5.3;Scheduling;**658**;Aug 13, 1993;Build 23
  1.  ;
  1.  ;Reference is made to ICR's #4837 and #6185
  1.  Q
  1.  ;
  1. FINDTXT(SDGMR,SDRPA,SDTXT) ;find text in word processing field
  1.  ;INPUT:
  1.  ; SDGMR - Pointer to REQUEST/CONSULTATION file
  1.  ; SDRPA - Pointer to REQUEST PROCESSING ACTIVITY in REQUEST/CONSULTATION file
  1.  ;RETURN:
  1.  ; 1=Text Fount; 0=Not Found
  1.  N SDI,SDJ,SDLINE,SDMSG,SDPREV,SDRET,SDTHIS,SDWP,X    ;alb/sat 651 add SDLINE
  1.  S (SDTHIS,SDPREV)=""
  1.  S SDRET=0
  1.  S SDTXT=$G(SDTXT) S:SDTXT'="" SDTXT=$$UP^XLFSTR(SDTXT)  ;alb/sat 651
  1.  K SDWP S X=$$GET1^DIQ(123.02,SDRPA_","_SDGMR_",",5,"","SDWP","SDMSG")   ;ICR 6185
  1.  S SDI=0 F  S SDI=$O(SDWP(SDI)) Q:SDI=""  D  Q:SDRET=1
  1.  .S SDTHIS=SDWP(SDI)
  1.  .;alb/sat 651 begin modification
  1.  .;I $$UP^XLFSTR(SDPREV_SDTHIS)[SDTXT S SDRET=1
  1.  .S SDLINE=$$UP^XLFSTR(SDPREV_SDTHIS)
  1.  .I SDTXT'="" S:SDLINE[SDTXT SDRET=1 Q
  1.  .F SDJ=1:1 S SDTXT=$P($T(SDTXT+SDJ),";;",2) Q:SDTXT=""  D  Q:SDRET=1
  1.  ..S:SDLINE[SDTXT SDRET=1
  1.  .;alb/sat 651 end modification
  1.  .S SDPREV=SDTHIS
  1.  Q SDRET
  1.  ;
  1.  ;alb/sat 651
  1. SDTXT  ;
  1.  ;;CANCEL
  1.  ;;NOSHOW
  1.  ;;NO-SHOW
  1.  ;;NO SHOW
  1.  ;
  1.  ;
  1. PRIO(SDGMR) ;
  1.  N CNT,F81,FED,PRIO,PRIO1,RET,SDED,SDI   ;alb/sat 658 added CNT, F81 and SDI
  1.  ;alb/sat 658 start modification - if GMRC*3.0*81 has been installed/loaded at or before the file entry date/time, then always use the Earliest Date (Clinically Indicated Date)
  1.  S F81=9999999
  1.  S CNT=$$INSTALDT^XPDUTL("GMRC*3.0*81",.RET)
  1.  I CNT>0 S F81=$O(RET(0))
  1.  S SDED=$P($$GET1^DIQ(123,SDGMR_",",17,"I"),".",1)   ;earliest date  ;ICR 6185  ;alb/sat 658 moved this and next line up from under 'S PRIO=""'
  1.  S FED=$P($$GET1^DIQ(123,SDGMR_",",.01,"I"),".",1)   ;file entry date  ;ICR 4837
  1.  S PRIO=""
  1.  I F81'>FED S PRIO=SDED G PRIOX
  1.  ;alb/sat 658 end modification
  1.  S PRIO1=$$GET1^DIQ(123,SDGMR_",",5)                 ;urgency text  ;ICR 4837
  1.  I SDED="" S PRIO=PRIO1               ;2.6.17.2 - use URGENCY text if EARLIEST DATE is null
  1.  I (PRIO=""),(FED="")!(SDED'=FED) S PRIO=SDED  ;2.6.17.1 - use EARLIEST DATE if not = FILE ENTRY DATE
  1.  I (PRIO=""),((PRIO1["STAT")!(PRIO1["NEXT AVAILABLE")!(PRIO1["EMERGENCY")!(PRIO1["TODAY")) S PRIO=SDED  ;2.6.17.3
  1.  S:PRIO="" PRIO=PRIO1  ;2.6.17.3
  1. PRIOX Q PRIO   ;alb/sat 658 added PRIOX tag
  1.  ;
  1. SDCHED(DFN,SDACTDT,SDTSVC) ;look for appointment with stop code for REQUEST SERVICES
  1.  ;INPUT:
  1.  ; DFN     - patient ID pointer to PATIENT file
  1.  ; SDACTDT - actual activity date in FM format
  1.  ; SDTSVC  - request services ID pointer to REQUEST SERVICES file 123.5
  1.  ;RETURN:
  1.  ; 0 = no appointment found with matching stop code
  1.  ; 1 = appointment found with matching stop code
  1.  ;Q 1   ;do not check for match for now
  1.  N SDCL,SDI,SDRET,SDSTP,SDSTPL
  1.  S SDRET=0
  1.  S SDTSVC=$G(SDTSVC)
  1.  Q:SDTSVC="" 0
  1.  S SDACTDT=$P($G(SDACTDT),".",1)
  1.  I SDACTDT'?7N S SDACTDT=1410102   ;alb/sat 658 use valid FM range instead of 1000101
  1.  S SDI=0 F  S SDI=$O(^GMR(123.5,SDTSVC,688,SDI)) Q:SDI'>0  D  Q:SDRET=1
  1.  .S SDSTPL(+$P($G(^GMR(123.5,SDTSVC,688,SDI,0)),U,1))=""    ;ICR 4557
  1.  S SDI=$$FMADD^XLFDT(SDACTDT,-2) F  S SDI=$O(^DPT(DFN,"S",SDI)) Q:SDI'>0  D
  1.  .S SDCL=$$GET1^DIQ(2.98,SDI_","_DFN_",",.01,"I")
  1.  .S SDSTP=$$GET1^DIQ(44,SDCL_",",8,"I")
  1.  .I $$GET1^DIQ(2.98,SDI_","_DFN_",",15,"I")="",$D(SDSTPL(+SDSTP)) S SDRET=1   ;alb/sat 651
  1.  Q SDRET