- SDEC51A ;ALB/SAT - VISTA SCHEDULING RPCS ;MAR 15, 2017
- ;;5.3;Scheduling;**658**;Aug 13, 1993;Build 23
- ;
- ;Reference is made to ICR's #4837 and #6185
- Q
- ;
- FINDTXT(SDGMR,SDRPA,SDTXT) ;find text in word processing field
- ;INPUT:
- ; SDGMR - Pointer to REQUEST/CONSULTATION file
- ; SDRPA - Pointer to REQUEST PROCESSING ACTIVITY in REQUEST/CONSULTATION file
- ;RETURN:
- ; 1=Text Fount; 0=Not Found
- N SDI,SDJ,SDLINE,SDMSG,SDPREV,SDRET,SDTHIS,SDWP,X ;alb/sat 651 add SDLINE
- S (SDTHIS,SDPREV)=""
- S SDRET=0
- S SDTXT=$G(SDTXT) S:SDTXT'="" SDTXT=$$UP^XLFSTR(SDTXT) ;alb/sat 651
- K SDWP S X=$$GET1^DIQ(123.02,SDRPA_","_SDGMR_",",5,"","SDWP","SDMSG") ;ICR 6185
- S SDI=0 F S SDI=$O(SDWP(SDI)) Q:SDI="" D Q:SDRET=1
- .S SDTHIS=SDWP(SDI)
- .;alb/sat 651 begin modification
- .;I $$UP^XLFSTR(SDPREV_SDTHIS)[SDTXT S SDRET=1
- .S SDLINE=$$UP^XLFSTR(SDPREV_SDTHIS)
- .I SDTXT'="" S:SDLINE[SDTXT SDRET=1 Q
- .F SDJ=1:1 S SDTXT=$P($T(SDTXT+SDJ),";;",2) Q:SDTXT="" D Q:SDRET=1
- ..S:SDLINE[SDTXT SDRET=1
- .;alb/sat 651 end modification
- .S SDPREV=SDTHIS
- Q SDRET
- ;
- ;alb/sat 651
- SDTXT ;
- ;;CANCEL
- ;;NOSHOW
- ;;NO-SHOW
- ;;NO SHOW
- ;
- ;
- PRIO(SDGMR) ;
- N CNT,F81,FED,PRIO,PRIO1,RET,SDED,SDI ;alb/sat 658 added CNT, F81 and SDI
- ;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)
- S F81=9999999
- S CNT=$$INSTALDT^XPDUTL("GMRC*3.0*81",.RET)
- I CNT>0 S F81=$O(RET(0))
- 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=""'
- S FED=$P($$GET1^DIQ(123,SDGMR_",",.01,"I"),".",1) ;file entry date ;ICR 4837
- S PRIO=""
- I F81'>FED S PRIO=SDED G PRIOX
- ;alb/sat 658 end modification
- S PRIO1=$$GET1^DIQ(123,SDGMR_",",5) ;urgency text ;ICR 4837
- I SDED="" S PRIO=PRIO1 ;2.6.17.2 - use URGENCY text if EARLIEST DATE is null
- I (PRIO=""),(FED="")!(SDED'=FED) S PRIO=SDED ;2.6.17.1 - use EARLIEST DATE if not = FILE ENTRY DATE
- I (PRIO=""),((PRIO1["STAT")!(PRIO1["NEXT AVAILABLE")!(PRIO1["EMERGENCY")!(PRIO1["TODAY")) S PRIO=SDED ;2.6.17.3
- S:PRIO="" PRIO=PRIO1 ;2.6.17.3
- PRIOX Q PRIO ;alb/sat 658 added PRIOX tag
- ;
- SDCHED(DFN,SDACTDT,SDTSVC) ;look for appointment with stop code for REQUEST SERVICES
- ;INPUT:
- ; DFN - patient ID pointer to PATIENT file
- ; SDACTDT - actual activity date in FM format
- ; SDTSVC - request services ID pointer to REQUEST SERVICES file 123.5
- ;RETURN:
- ; 0 = no appointment found with matching stop code
- ; 1 = appointment found with matching stop code
- ;Q 1 ;do not check for match for now
- N SDCL,SDI,SDRET,SDSTP,SDSTPL
- S SDRET=0
- S SDTSVC=$G(SDTSVC)
- Q:SDTSVC="" 0
- S SDACTDT=$P($G(SDACTDT),".",1)
- I SDACTDT'?7N S SDACTDT=1410102 ;alb/sat 658 use valid FM range instead of 1000101
- S SDI=0 F S SDI=$O(^GMR(123.5,SDTSVC,688,SDI)) Q:SDI'>0 D Q:SDRET=1
- .S SDSTPL(+$P($G(^GMR(123.5,SDTSVC,688,SDI,0)),U,1))="" ;ICR 4557
- S SDI=$$FMADD^XLFDT(SDACTDT,-2) F S SDI=$O(^DPT(DFN,"S",SDI)) Q:SDI'>0 D
- .S SDCL=$$GET1^DIQ(2.98,SDI_","_DFN_",",.01,"I")
- .S SDSTP=$$GET1^DIQ(44,SDCL_",",8,"I")
- .I $$GET1^DIQ(2.98,SDI_","_DFN_",",15,"I")="",$D(SDSTPL(+SDSTP)) S SDRET=1 ;alb/sat 651
- Q SDRET
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDEC51A 3336 printed Mar 13, 2025@21:55:44 Page 2
- SDEC51A ;ALB/SAT - VISTA SCHEDULING RPCS ;MAR 15, 2017
- +1 ;;5.3;Scheduling;**658**;Aug 13, 1993;Build 23
- +2 ;
- +3 ;Reference is made to ICR's #4837 and #6185
- +4 QUIT
- +5 ;
- FINDTXT(SDGMR,SDRPA,SDTXT) ;find text in word processing field
- +1 ;INPUT:
- +2 ; SDGMR - Pointer to REQUEST/CONSULTATION file
- +3 ; SDRPA - Pointer to REQUEST PROCESSING ACTIVITY in REQUEST/CONSULTATION file
- +4 ;RETURN:
- +5 ; 1=Text Fount; 0=Not Found
- +6 ;alb/sat 651 add SDLINE
- NEW SDI,SDJ,SDLINE,SDMSG,SDPREV,SDRET,SDTHIS,SDWP,X
- +7 SET (SDTHIS,SDPREV)=""
- +8 SET SDRET=0
- +9 ;alb/sat 651
- SET SDTXT=$GET(SDTXT)
- if SDTXT'=""
- SET SDTXT=$$UP^XLFSTR(SDTXT)
- +10 ;ICR 6185
- KILL SDWP
- SET X=$$GET1^DIQ(123.02,SDRPA_","_SDGMR_",",5,"","SDWP","SDMSG")
- +11 SET SDI=0
- FOR
- SET SDI=$ORDER(SDWP(SDI))
- if SDI=""
- QUIT
- Begin DoDot:1
- +12 SET SDTHIS=SDWP(SDI)
- +13 ;alb/sat 651 begin modification
- +14 ;I $$UP^XLFSTR(SDPREV_SDTHIS)[SDTXT S SDRET=1
- +15 SET SDLINE=$$UP^XLFSTR(SDPREV_SDTHIS)
- +16 IF SDTXT'=""
- if SDLINE[SDTXT
- SET SDRET=1
- QUIT
- +17 FOR SDJ=1:1
- SET SDTXT=$PIECE($TEXT(SDTXT+SDJ),";;",2)
- if SDTXT=""
- QUIT
- Begin DoDot:2
- +18 if SDLINE[SDTXT
- SET SDRET=1
- End DoDot:2
- if SDRET=1
- QUIT
- +19 ;alb/sat 651 end modification
- +20 SET SDPREV=SDTHIS
- End DoDot:1
- if SDRET=1
- QUIT
- +21 QUIT SDRET
- +22 ;
- +23 ;alb/sat 651
- SDTXT ;
- +1 ;;CANCEL
- +2 ;;NOSHOW
- +3 ;;NO-SHOW
- +4 ;;NO SHOW
- +5 ;
- +6 ;
- PRIO(SDGMR) ;
- +1 ;alb/sat 658 added CNT, F81 and SDI
- NEW CNT,F81,FED,PRIO,PRIO1,RET,SDED,SDI
- +2 ;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)
- +3 SET F81=9999999
- +4 SET CNT=$$INSTALDT^XPDUTL("GMRC*3.0*81",.RET)
- +5 IF CNT>0
- SET F81=$ORDER(RET(0))
- +6 ;earliest date ;ICR 6185 ;alb/sat 658 moved this and next line up from under 'S PRIO=""'
- SET SDED=$PIECE($$GET1^DIQ(123,SDGMR_",",17,"I"),".",1)
- +7 ;file entry date ;ICR 4837
- SET FED=$PIECE($$GET1^DIQ(123,SDGMR_",",.01,"I"),".",1)
- +8 SET PRIO=""
- +9 IF F81'>FED
- SET PRIO=SDED
- GOTO PRIOX
- +10 ;alb/sat 658 end modification
- +11 ;urgency text ;ICR 4837
- SET PRIO1=$$GET1^DIQ(123,SDGMR_",",5)
- +12 ;2.6.17.2 - use URGENCY text if EARLIEST DATE is null
- IF SDED=""
- SET PRIO=PRIO1
- +13 ;2.6.17.1 - use EARLIEST DATE if not = FILE ENTRY DATE
- IF (PRIO="")
- IF (FED="")!(SDED'=FED)
- SET PRIO=SDED
- +14 ;2.6.17.3
- IF (PRIO="")
- IF ((PRIO1["STAT")!(PRIO1["NEXT AVAILABLE")!(PRIO1["EMERGENCY")!(PRIO1["TODAY"))
- SET PRIO=SDED
- +15 ;2.6.17.3
- if PRIO=""
- SET PRIO=PRIO1
- PRIOX ;alb/sat 658 added PRIOX tag
- QUIT PRIO
- +1 ;
- SDCHED(DFN,SDACTDT,SDTSVC) ;look for appointment with stop code for REQUEST SERVICES
- +1 ;INPUT:
- +2 ; DFN - patient ID pointer to PATIENT file
- +3 ; SDACTDT - actual activity date in FM format
- +4 ; SDTSVC - request services ID pointer to REQUEST SERVICES file 123.5
- +5 ;RETURN:
- +6 ; 0 = no appointment found with matching stop code
- +7 ; 1 = appointment found with matching stop code
- +8 ;Q 1 ;do not check for match for now
- +9 NEW SDCL,SDI,SDRET,SDSTP,SDSTPL
- +10 SET SDRET=0
- +11 SET SDTSVC=$GET(SDTSVC)
- +12 if SDTSVC=""
- QUIT 0
- +13 SET SDACTDT=$PIECE($GET(SDACTDT),".",1)
- +14 ;alb/sat 658 use valid FM range instead of 1000101
- IF SDACTDT'?7N
- SET SDACTDT=1410102
- +15 SET SDI=0
- FOR
- SET SDI=$ORDER(^GMR(123.5,SDTSVC,688,SDI))
- if SDI'>0
- QUIT
- Begin DoDot:1
- +16 ;ICR 4557
- SET SDSTPL(+$PIECE($GET(^GMR(123.5,SDTSVC,688,SDI,0)),U,1))=""
- End DoDot:1
- if SDRET=1
- QUIT
- +17 SET SDI=$$FMADD^XLFDT(SDACTDT,-2)
- FOR
- SET SDI=$ORDER(^DPT(DFN,"S",SDI))
- if SDI'>0
- QUIT
- Begin DoDot:1
- +18 SET SDCL=$$GET1^DIQ(2.98,SDI_","_DFN_",",.01,"I")
- +19 SET SDSTP=$$GET1^DIQ(44,SDCL_",",8,"I")
- +20 ;alb/sat 651
- IF $$GET1^DIQ(2.98,SDI_","_DFN_",",15,"I")=""
- IF $DATA(SDSTPL(+SDSTP))
- SET SDRET=1
- End DoDot:1
- +21 QUIT SDRET