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

SDES2QRYAPREQSA.m

Go to the documentation of this file.
  1. SDES2QRYAPREQSA ;ALB/BWF - QUERY APPOINTMENT REQUESTS; JAN 4,2023
  1. ;;5.3;Scheduling;**869,875,885**;Aug 13, 1993;Build 5
  1. ;;Per VHA Directive 6402, this routine should not be modified
  1. ;
  1. Q
  1. FINDBYREQ(ERRORS,SDINPUT,FLTRORIGDATE,FLTRPIDDATE,STARTDT,ENDDT) ;
  1. N REQCNT,DFN,PRIORITYGROUP,CURRENTENR,PATSVCCONN,PATSCPERCENT,COUNT,REQCNT,CLINIEN,REQIEN,REQDATE,STOPDATE
  1. N PGROUP,CLINIC,FLTRPRIOGROUP,SERVICELIST,STAT,STOPCDATE,CONSIEN,GMRSERVICE,INVSTART,RECALLIEN,SERVICE
  1. S COUNT=0
  1. ;
  1. ; appointment requests
  1. ;
  1. I $D(SDINPUT("FILTER","REQUEST TYPE","APPT"))!($D(SDINPUT("FILTER","REQUEST TYPE","ALL"))) D
  1. .S REQCNT=0
  1. .; by clinic
  1. .I $D(SDINPUT("FILTER","CLINIC")) D
  1. ..S CLINIEN=0 F S CLINIEN=$O(SDINPUT("FILTER","CLINIC",CLINIEN)) Q:'CLINIEN!(REQCNT>SDINPUT("MAX NUMBER OF RECORDS")) D
  1. ...; use GCC when filtering by PID DATE
  1. ...I FLTRPIDDATE'="" D Q
  1. ....S REQIEN=0 F S REQIEN=$O(^SDEC(409.85,"ECC","O",CLINIEN,FLTRPIDDATE,REQIEN)) Q:'REQIEN!(REQCNT>SDINPUT("MAX NUMBER OF RECORDS")) D
  1. .....S DFN=$$GET1^DIQ(409.85,REQIEN,.01,"I") Q:'DFN
  1. .....D GETPATENR^SDES2QRYAPREQSB(DFN,.PRIORITYGROUP,.CURRENTENR,.PATSVCCONN,.PATSCPERCENT)
  1. .....I $D(SDINPUT("FILTER","PRIORITY GROUP")),('$D(SDINPUT("FILTER","PRIORITY GROUP",PRIORITYGROUP))&'$D(SDINPUT("FILTER","PRIORITY GROUP","ALL"))) Q
  1. .....D FLTRAPPTREQ^SDES2QRYAPREQSB(REQIEN,.SDINPUT,FLTRORIGDATE,FLTRPIDDATE,STARTDT,ENDDT,PRIORITYGROUP,PATSVCCONN,PATSCPERCENT,.COUNT,.REQCNT)
  1. ...; use EC when not filtering by PID DATE
  1. ...S REQDATE=$S(FLTRORIGDATE:FLTRORIGDATE-.01,1:STARTDT-.01)
  1. ...S STOPDATE=$S(FLTRORIGDATE:FLTRORIGDATE_.9999,1:ENDDT)
  1. ...F S REQDATE=$O(^SDEC(409.85,"EC","O",CLINIEN,REQDATE)) Q:'REQDATE!(REQDATE>STOPDATE)!(REQCNT>SDINPUT("MAX NUMBER OF RECORDS")) D
  1. ....S REQIEN=0 F S REQIEN=$O(^SDEC(409.85,"EC","O",CLINIEN,REQDATE,REQIEN)) Q:'REQIEN!(REQCNT>SDINPUT("MAX NUMBER OF RECORDS")) D
  1. .....S DFN=$$GET1^DIQ(409.85,REQIEN,.01,"I") Q:'DFN
  1. .....D GETPATENR^SDES2QRYAPREQSB(DFN,.PRIORITYGROUP,.CURRENTENR,.PATSVCCONN,.PATSCPERCENT)
  1. .....I $D(SDINPUT("FILTER","PRIORITY GROUP")),('$D(SDINPUT("FILTER","PRIORITY GROUP",PRIORITYGROUP))&'$D(SDINPUT("FILTER","PRIORITY GROUP","ALL"))) Q
  1. .....D FLTRAPPTREQ^SDES2QRYAPREQSB(REQIEN,.SDINPUT,FLTRORIGDATE,FLTRPIDDATE,STARTDT,ENDDT,PRIORITYGROUP,PATSVCCONN,PATSCPERCENT,.COUNT,.REQCNT)
  1. .;
  1. .; by service
  1. .I $D(SDINPUT("FILTER","SERVICE")) D
  1. ..S SERVICE=0 F S SERVICE=$O(SDINPUT("FILTER","SERVICE",SERVICE)) Q:'SERVICE!(REQCNT>SDINPUT("MAX NUMBER OF RECORDS")) D
  1. ...;
  1. ...; filter by PID date (aka desired date)
  1. ...I FLTRPIDDATE D Q
  1. ....S REQDATE=FLTRPIDDATE-.01
  1. ....S STOPDATE=FLTRPIDDATE_.9999
  1. ....F S REQDATE=$O(^SDEC(409.85,"ESC","O",SERVICE,REQDATE)) Q:'REQDATE!(REQDATE>STOPDATE)!(REQCNT>SDINPUT("MAX NUMBER OF RECORDS")) D
  1. .....S REQIEN=0 F S REQIEN=$O(^SDEC(409.85,"ESC","O",SERVICE,REQDATE,REQIEN)) Q:'REQIEN!(REQCNT>SDINPUT("MAX NUMBER OF RECORDS")) D
  1. ......S DFN=$$GET1^DIQ(409.85,REQIEN,.01,"I") Q:'DFN
  1. ......D GETPATENR^SDES2QRYAPREQSB(DFN,.PRIORITYGROUP,.CURRENTENR,.PATSVCCONN,.PATSCPERCENT)
  1. ......I $D(SDINPUT("FILTER","PRIORITY GROUP")),('$D(SDINPUT("FILTER","PRIORITY GROUP",PRIORITYGROUP))&'$D(SDINPUT("FILTER","PRIORITY GROUP","ALL"))) Q
  1. ......D FLTRAPPTREQ^SDES2QRYAPREQSB(REQIEN,.SDINPUT,FLTRORIGDATE,FLTRPIDDATE,STARTDT,ENDDT,PRIORITYGROUP,PATSVCCONN,PATSCPERCENT,.COUNT,.REQCNT)
  1. ...;
  1. ...; filter by enrollment priority
  1. ...I $D(SDINPUT("FILTER","PRIORITY GROUP")) D Q
  1. ....S REQDATE=STARTDT-.01
  1. ....S STOPDATE=ENDDT_.9999
  1. ....; all groups
  1. ....I $D(SDINPUT("FILTER","PRIORITY GROUP","ALL")) D Q
  1. .....S PGROUP="" F S PGROUP=$O(^SDEC(409.85,"ESP","O",SERVICE,PGROUP)) Q:PGROUP=""!(REQCNT>SDINPUT("MAX NUMBER OF RECORDS")) D
  1. ......F S REQDATE=$O(^SDEC(409.85,"ESP","O",SERVICE,PGROUP,REQDATE)) Q:'REQDATE!(REQDATE>STOPDATE)!(REQCNT>SDINPUT("MAX NUMBER OF RECORDS")) D
  1. .......S REQIEN=0 F S REQIEN=$O(^SDEC(409.85,"ESP","O",SERVICE,PGROUP,REQDATE,REQIEN)) Q:'REQIEN!(REQCNT>SDINPUT("MAX NUMBER OF RECORDS")) D
  1. ........S DFN=$$GET1^DIQ(409.85,REQIEN,.01,"I") Q:'DFN
  1. ........D GETPATENR^SDES2QRYAPREQSB(DFN,.PRIORITYGROUP,.CURRENTENR,.PATSVCCONN,.PATSCPERCENT)
  1. ........I $D(SDINPUT("FILTER","PRIORITY GROUP")),('$D(SDINPUT("FILTER","PRIORITY GROUP",PRIORITYGROUP))&'$D(SDINPUT("FILTER","PRIORITY GROUP","ALL"))) Q
  1. ........D FLTRAPPTREQ^SDES2QRYAPREQSB(REQIEN,.SDINPUT,FLTRORIGDATE,FLTRPIDDATE,STARTDT,ENDDT,PRIORITYGROUP,PATSVCCONN,PATSCPERCENT,.COUNT,.REQCNT)
  1. ....; filter by specific groups - start at A to only pick up "GROUP n"
  1. ....S FLTRPRIOGROUP="A" F S FLTRPRIOGROUP=$O(SDINPUT("FILTER","PRIORITY GROUP",FLTRPRIOGROUP)) Q:FLTRPRIOGROUP="" D
  1. .....S PGROUP=$P(FLTRPRIOGROUP," ",2)
  1. .....F S REQDATE=$O(^SDEC(409.85,"ESP","O",SERVICE,PGROUP,REQDATE)) Q:'REQDATE!(REQDATE>STOPDATE)!(REQCNT>SDINPUT("MAX NUMBER OF RECORDS")) D
  1. ......S REQIEN=0 F S REQIEN=$O(^SDEC(409.85,"ESP","O",SERVICE,PGROUP,REQDATE,REQIEN)) Q:'REQIEN!(REQCNT>SDINPUT("MAX NUMBER OF RECORDS")) D
  1. .......S DFN=$$GET1^DIQ(409.85,REQIEN,.01,"I") Q:'DFN
  1. .......D GETPATENR^SDES2QRYAPREQSB(DFN,.PRIORITYGROUP,.CURRENTENR,.PATSVCCONN,.PATSCPERCENT)
  1. .......I $D(SDINPUT("FILTER","PRIORITY GROUP")),('$D(SDINPUT("FILTER","PRIORITY GROUP",PRIORITYGROUP))&'$D(SDINPUT("FILTER","PRIORITY GROUP","ALL"))) Q
  1. .......D FLTRAPPTREQ^SDES2QRYAPREQSB(REQIEN,.SDINPUT,FLTRORIGDATE,FLTRPIDDATE,STARTDT,ENDDT,PRIORITYGROUP,PATSVCCONN,PATSCPERCENT,.COUNT,.REQCNT)
  1. ...;
  1. ...S REQDATE=STARTDT-.01
  1. ...S STOPDATE=ENDDT_.9999
  1. ...F S REQDATE=$O(^SDEC(409.85,"ES","O",SERVICE,REQDATE)) Q:'REQDATE!(REQDATE>STOPDATE)!(REQCNT>SDINPUT("MAX NUMBER OF RECORDS")) D
  1. ....S REQIEN=0 F S REQIEN=$O(^SDEC(409.85,"ES","O",SERVICE,REQDATE,REQIEN)) Q:'REQIEN!(REQDATE>STOPDATE)!(REQCNT>SDINPUT("MAX NUMBER OF RECORDS")) D
  1. .....S DFN=$$GET1^DIQ(409.85,REQIEN,.01,"I") Q:'DFN
  1. .....D GETPATENR^SDES2QRYAPREQSB(DFN,.PRIORITYGROUP,.CURRENTENR,.PATSVCCONN,.PATSCPERCENT)
  1. .....I $D(SDINPUT("FILTER","PRIORITY GROUP")),('$D(SDINPUT("FILTER","PRIORITY GROUP",PRIORITYGROUP))&'$D(SDINPUT("FILTER","PRIORITY GROUP","ALL"))) Q
  1. .....D FLTRAPPTREQ^SDES2QRYAPREQSB(REQIEN,.SDINPUT,FLTRORIGDATE,FLTRPIDDATE,STARTDT,ENDDT,PRIORITYGROUP,PATSVCCONN,PATSCPERCENT,.COUNT,.REQCNT)
  1. ;
  1. ; consults
  1. I $D(SDINPUT("FILTER","REQUEST TYPE","CONSULT"))!($D(SDINPUT("FILTER","REQUEST TYPE","ALL"))) D
  1. .S REQCNT=0
  1. .; by clinic
  1. .I $D(SDINPUT("FILTER","CLINIC")) D Q
  1. ..S CLINIC=0 F S CLINIC=$O(SDINPUT("FILTER","CLINIC",CLINIC)) Q:'CLINIC!(REQCNT>SDINPUT("MAX NUMBER OF RECORDS")) D
  1. ...S CONSIEN=0 F S CONSIEN=$O(^GMR(123,"H",CLINIC,CONSIEN)) Q:'CONSIEN!(REQCNT>SDINPUT("MAX NUMBER OF RECORDS")) D
  1. ....Q:$$REQCHK(CONSIEN)
  1. ....S DFN=$$GET1^DIQ(123,CONSIEN,.02,"I") Q:'DFN
  1. ....D GETPATENR^SDES2QRYAPREQSB(DFN,.PRIORITYGROUP,.CURRENTENR,.PATSVCCONN,.PATSCPERCENT)
  1. ....I $D(SDINPUT("FILTER","PRIORITY GROUP")),('$D(SDINPUT("FILTER","PRIORITY GROUP",PRIORITYGROUP))&'$D(SDINPUT("FILTER","PRIORITY GROUP","ALL"))) Q
  1. ....D FLTRCONSULT^SDES2QRYAPREQSB(CONSIEN,.SDINPUT,FLTRORIGDATE,FLTRPIDDATE,STARTDT,ENDDT,PRIORITYGROUP,PATSVCCONN,PATSCPERCENT,.COUNT,.REQCNT)
  1. .; by service
  1. .I $D(SDINPUT("FILTER","SERVICE")) D Q
  1. ..S SERVICE=0 F S SERVICE=$O(SDINPUT("FILTER","SERVICE",SERVICE)) Q:'SERVICE D
  1. ...S SERVICELIST(SERVICE)=SERVICE
  1. ..D GETSVC^SDES2QRYAPREQSA(.GMRSVC,.SERVICELIST)
  1. ..S GMRSERVICE=0 F S GMRSERVICE=$O(GMRSVC(GMRSERVICE)) Q:'GMRSERVICE D
  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 Q:REQCNT>SDINPUT("MAX NUMBER OF RECORDS") D
  1. ....Q:STAT=""
  1. ....S INVSTART=9999999-ENDDT-1
  1. ....F S INVSTART=$O(^GMR(123,"AE",GMRSERVICE,STAT,INVSTART)) Q:'INVSTART!($P(INVSTART,".")>(9999999-STARTDT))!(REQCNT>SDINPUT("MAX NUMBER OF RECORDS")) D
  1. .....S CONSIEN=0 F S CONSIEN=$O(^GMR(123,"AE",GMRSERVICE,STAT,INVSTART,CONSIEN)) Q:'CONSIEN!(REQCNT>SDINPUT("MAX NUMBER OF RECORDS")) D
  1. ......Q:$$REQCHK(CONSIEN)
  1. ......S DFN=$$GET1^DIQ(123,CONSIEN,.02,"I") Q:'DFN
  1. ......D GETPATENR^SDES2QRYAPREQSB(DFN,.PRIORITYGROUP,.CURRENTENR,.PATSVCCONN,.PATSCPERCENT)
  1. ......I $D(SDINPUT("FILTER","PRIORITY GROUP")),('$D(SDINPUT("FILTER","PRIORITY GROUP",PRIORITYGROUP))&'$D(SDINPUT("FILTER","PRIORITY GROUP","ALL"))) Q
  1. ......D FLTRCONSULT^SDES2QRYAPREQSB(CONSIEN,.SDINPUT,FLTRORIGDATE,FLTRPIDDATE,STARTDT,ENDDT,PRIORITYGROUP,PATSVCCONN,PATSCPERCENT,.COUNT,.REQCNT)
  1. ;
  1. ; recalls
  1. I $D(SDINPUT("FILTER","REQUEST TYPE","RECALL"))!($D(SDINPUT("FILTER","REQUEST TYPE","ALL"))) D
  1. .S REQCNT=0
  1. .I $D(SDINPUT("FILTER","CLINIC")) D Q
  1. ..S CLINIC=0 F S CLINIC=$O(SDINPUT("FILTER","CLINIC",CLINIC)) Q:'CLINIC!(REQCNT>SDINPUT("MAX NUMBER OF RECORDS")) D
  1. ...S RECALLIEN=0 F S RECALLIEN=$O(^SD(403.5,"E",CLINIC,RECALLIEN)) Q:'RECALLIEN!(REQCNT>SDINPUT("MAX NUMBER OF RECORDS")) D
  1. ....S DFN=$$GET1^DIQ(403.5,RECALLIEN,.01,"I") Q:'DFN
  1. ....D GETPATENR^SDES2QRYAPREQSB(DFN,.PRIORITYGROUP,.CURRENTENR,.PATSVCCONN,.PATSCPERCENT)
  1. ....I $D(SDINPUT("FILTER","PRIORITY GROUP")),('$D(SDINPUT("FILTER","PRIORITY GROUP",PRIORITYGROUP))&'$D(SDINPUT("FILTER","PRIORITY GROUP","ALL"))) Q
  1. ....D FLTRRECALL^SDES2QRYAPREQSB(RECALLIEN,.SDINPUT,FLTRORIGDATE,FLTRPIDDATE,STARTDT,ENDDT,PRIORITYGROUP,PATSVCCONN,PATSCPERCENT,.COUNT,.REQCNT)
  1. Q
  1. ;
  1. REQCHK(SDGMR,DFN) ;alb/sat 658 - new rules for consult check
  1. N CPRSTAT,IFC,OSACT,OSPEND
  1. Q:'$D(^GMR(123,+$G(SDGMR),0)) 1
  1. S OSACT=$O(^ORD(100.01,"B","ACTIVE",0))
  1. S OSPEND=$O(^ORD(100.01,"B","PENDING",0))
  1. S CPRSTAT=$$GET1^DIQ(123,SDGMR_",",8,"I")
  1. Q:'((CPRSTAT=OSACT)!(CPRSTAT=OSPEND)) 1
  1. S IFC=$$GET1^DIQ(123,SDGMR,.125,"I")
  1. Q:IFC="P" 1
  1. Q 0
  1. ;
  1. CHECKSERVICES(SDINPUT,SERVICEIEN) ;
  1. N STOPCODES,FOUND,SFIENS,STOPCODE
  1. S FOUND=0
  1. D GETS^DIQ(123.5,SERVICEIEN_",","688*","IE","STOPCODES")
  1. S SFIENS="" F S SFIENS=$O(STOPCODES(123.5688,SFIENS)) Q:SFIENS="" D
  1. .S STOPCODE=$G(STOPCODES(123.5688,SFIENS,.01,"I")) Q:'STOPCODE
  1. .I $D(SDINPUT("FILTER","SERVICE",STOPCODE)) S FOUND=1
  1. Q FOUND
  1. ;
  1. STOP(GMRSTOP,SDGMR) ;get stop codes from field 688 of REQUEST SERVICES file 123.5
  1. ; .GMRSTOP - returned array of STOP CODE pointers to CLINIC STOP file 40.7
  1. ; GMRSTOP(<clinic stop id>)=<clinic stop name>
  1. ; SDGMR - (required) pointer to REQUEST/CONSULTATION file 123
  1. N RS,SDDATA,SDI,SDIEN,SDNM
  1. K GMRSTOP
  1. S RS=$$GET1^DIQ(123,SDGMR_",",1,"I") ;get TO SERVICE
  1. D GETS^DIQ(123.5,RS_",","688*","IE","SDDATA")
  1. S SDI=0 F S SDI=$O(SDDATA(123.5688,SDI)) Q:SDI="" D
  1. .S SDIEN=$G(SDDATA(123.5688,SDI,.01,"I"))
  1. .S SDNM=$G(SDDATA(123.5688,SDI,.01,"E"))
  1. .S:+SDIEN GMRSTOP(SDIEN)=SDNM
  1. Q
  1. ;
  1. GETSVC(GMRSVC,SVC) ;get REQUEST SERVICES entries for given stop codes
  1. ; .GMRSVC - returned array of REQUEST SERVICES entries
  1. ; .SVC - input array of clinic stop codes SVC(NAME)=ID pointer to CLINIC STOP file 40.7
  1. N AB1,ID,SDN,STOP
  1. K GMRSVC
  1. S SDN="" F S SDN=$O(SVC(SDN)) Q:SDN="" D
  1. .I SVC(SDN)="" Q
  1. .S STOP=SVC(SDN) I '$D(^DIC(40.7,STOP,0)) Q
  1. .S ID=0 F S ID=$O(^GMR(123.5,"AB1",STOP,ID)) Q:ID="" D
  1. ..S AB1=0 F S AB1=$O(^GMR(123.5,"AB1",STOP,ID,AB1)) Q:AB1="" D
  1. ...Q:STOP'=$P($G(^GMR(123.5,ID,688,AB1,0)),U,1)
  1. ...S GMRSVC(ID)=""
  1. Q
  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 Q PRIO
  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. Q PRIO ;alb/sat 658 added PRIOX tag