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

SDEC01B.m

Go to the documentation of this file.
  1. SDEC01B ;ALB/SAT - VISTA SCHEDULING RPCS ;APR 08, 2016
  1. ;;5.3;Scheduling;**627,642,722**;Aug 13, 1993;Build 26
  1. ;
  1. Q
  1. ;
  1. RESDG(SDRES) ;remove SDEC RESOURCE from all SDEC RESOURCE GROUPs
  1. N SDECY,SDI,SDJ
  1. S SDECY=""
  1. S SDRES=$G(SDRES) Q:'+SDRES Q:'$D(^SDEC(409.831,+SDRES,0))
  1. S SDI=9999999 F S SDI=$O(^SDEC(409.832,"AB",+SDRES,SDI),-1) Q:SDI="" D
  1. .D DELRGI^SDEC(.SDECY,SDI,SDRES)
  1. Q
  1. ;
  1. RESDGA ;remove all inactive SDEC RESOURCEs from all SDEC RESOURCE GROUPs
  1. N SDI,X
  1. S SDI=0 F S SDI=$O(^SDEC(409.831,SDI)) Q:SDI'>0 S X=$$GET1^DIQ(409.831,SDI_",",.02)="YES" ;computed routine calls RESDG
  1. Q
  1. ;
  1. RESCK(SDRES) ;check if SDEC RESOURCE is inactive ;remove from all SDEC RESOURCE GROUPs if inactive
  1. N X
  1. S SDRES=$G(SDRES) Q:'+SDRES Q:'$D(^SDEC(409.831,+SDRES,0))
  1. S X=$$GET1^DIQ(409.831,SDRES_",",.02)="YES" ;computed routines calls RESDG
  1. Q
  1. ;
  1. USRDG(SDDUZ) ;remove SDEC RESOURCEs associated with SDDUZ from all SDEC RESOURCE GROUPs
  1. ; SDDUZ = pointer to NEW PERSON file 200
  1. N SDRES
  1. S SDRES=0 F S SDRES=$O(^SDEC(409.831,"AC","P",SDDUZ,SDRES)) Q:SDRES="" D
  1. .D RESDG(SDRES)
  1. Q
  1. ;
  1. ;
  1. RESPRV1(SDPRV,SDCL,SDPRVN) ;process 1 provider
  1. N EFFDT,EXPDT,PACT,SDFDA,SDIEN,SDMSG,SDRES
  1. ;look for existing resource
  1. S (EFFDT,EXPDT)=""
  1. S SDCL=$G(SDCL) Q:'$D(^SC(+SDCL,0))
  1. S SDPRV=$G(SDPRV) Q:'$D(^VA(200,+SDPRV,0))
  1. S SDPRVN=$G(SDPRVN) S:SDPRVN="" SDPRVN=$$GET1^DIQ(200,SDPRV_",",.01)
  1. S SDRES=$O(^SDEC(409.831,"AC","P",SDPRV,0))
  1. I SDRES'="",$$CHKP(SDPRV,SDRES) Q ;if entry found, update and quit
  1. ;S SDRES=$O(^SDEC(409.831,"B",SDPRVN,0)) ;look for existing SDEC RESOURCE id with provider name
  1. ;I SDRES'="",$$CHKP(SDPRV,SDRES) Q ;if entry found, update and quit
  1. S SDRES="+1"
  1. S PACT=$$PC^SDEC45(SDPRV,DT,.EFFDT,.EXPDT)
  1. S:EXPDT="" EXPDT=DT
  1. ;
  1. K SDFDA,SDIEN,SDMSG
  1. S SDFDA=$NA(SDFDA(409.831,SDRES_","))
  1. S @SDFDA@(.01)=SDPRVN
  1. S @SDFDA@(.012)=SDPRV_";VA(200,"
  1. S @SDFDA@(.015)=$E($$NOW^XLFDT,1,12)
  1. S @SDFDA@(.016)=DUZ
  1. S:+PACT @SDFDA@(.021)=EXPDT
  1. S @SDFDA@(.04)=SDCL
  1. D UPDATE^DIE("","SDFDA","SDIEN","SDMSG")
  1. S SDRES=SDIEN(1)
  1. Q
  1. CHKP(USER,SDRES) ;update existing provider resource entry
  1. ;returns 0=SDRES does not match USER ;1=matches and updated
  1. N EFFDT,EXPDT,RACT,PACT,RSN,RSTS,RSTYP,SDFDA,SCN,SDNOD,SCTS
  1. S RSTYP=$$GET1^DIQ(409.831,SDRES_",",.012,"I")
  1. Q:$P(RSTYP,";",1)'=USER 0
  1. ;
  1. S SCN=$$GET1^DIQ(200,USER_",",.01)
  1. S RSN=$$GET1^DIQ(409.831,SDRES_",",.01)
  1. S:SCN'=RSN SDFDA(409.831,SDRES_",",.01)=SCN
  1. ;
  1. S (EFFDT,EXPDT)=""
  1. S RACT=$$GET1^DIQ(409.831,SDRES_",",.02) S RACT=$S(RACT="YES":1,1:0)
  1. S PACT=$$PC^SDEC45(USER,DT,.EFFDT,.EXPDT)
  1. I RACT'=PACT D
  1. .S SDNOD=$G(^SDEC(409.831,SDRES,0))
  1. .I PACT=0 S SDFDA(409.831,SDRES_",",.021)="@",SDFDA(409.831,SDRES_",",.025)="@"
  1. .E S SDFDA(409.831,SDRES_",",.021)=$S(EXPDT="":$$FMADD^XLFDT(DT,-1),EXPDT'>DT:EXPDT,1:$$FMADD^XLFDT(DT,-1)),SDFDA(409.831,SDRES_",",.025)="@"
  1. ;
  1. I $D(SDFDA) D UPDATE^DIE("","SDFDA")
  1. D:+PACT RESCK(SDRES)
  1. Q 1
  1. ;
  1. CHKC(SDCL,SDRES) ;update existing clinic resource entry
  1. Q ; 722 disabled to stop changing the resource file wtc 2/22/19
  1. N CINACT,CREACT,RINACT,RREACT,RSN,RSTS,RSTYP,SDFDA,SCN,SCTS
  1. S RSTYP=$$GET1^DIQ(409.831,SDRES_",",.012,"I")
  1. Q:$P(RSTYP,";",1)'=SDCL
  1. ;
  1. S SCN=$$GET1^DIQ(44,SDCL_",",.01)
  1. S RSN=$$GET1^DIQ(409.831,SDRES_",",.01)
  1. S:SCN'=RSN SDFDA(409.831,SDRES_",",.01)=SCN
  1. ;
  1. S CINACT=$$GET1^DIQ(44,SDCL_",",2505,"I")
  1. S RINACT=$$GET1^DIQ(409.831,SDRES_",",.021,"I")
  1. S:CINACT'=RINACT SDFDA(409.831,SDRES_",",.021)=CINACT,SDFDA(409.831,SDRES_",",.022)="@"
  1. S CREACT=$$GET1^DIQ(44,SDCL_",",2506,"I")
  1. S RREACT=$$GET1^DIQ(409.831,SDRES_",",.025)
  1. S:CREACT'=RREACT SDFDA(409.831,SDRES_",",.025)=CREACT,SDFDA(409.831,SDRES_",",.026)="@"
  1. ;
  1. S SCTS=$$GET1^DIQ(44,SDCL_",",1917,"I") S SCTS=$S(SCTS=6:10,SCTS=4:15,SCTS=3:20,SCTS=2:30,1:60)
  1. S RSTS=$$GET1^DIQ(409.831,SDRES_",",.03,"I")
  1. S:SCTS'=RSTS SDFDA(409.831,SDRES_",",.03)=SCTS ;time scale
  1. ;
  1. I $D(SDFDA) D UPDATE^DIE("","SDFDA")
  1. Q
  1. ;
  1. RESCLIN1(SDCL) ;
  1. N SDCLN,SDDATA,SDFDA,SDFIELDS,SDFOUND,SDIEN,SDIN,SDLET,SDMSG,SDRES11,SDRESH,SDRN,SDMSG,SDTS,SDWP
  1. S SDFOUND=0
  1. ; .01 name; 2 type; 1912 len of appt; 2508 no show let; 2509 pre-appt let; 2510 clinic can let;
  1. S SDFIELDS=".01;2;50.01;1912;1917;2505;2506;2508;2509;2510"
  1. D GETS^DIQ(44,SDCL_",",SDFIELDS,"IE","SDDATA","SDMSG")
  1. I SDDATA(44,SDCL_",",2,"I")="C" D
  1. .;Q:SDDATA(44,SDCL_",",50.01,"I")=1 ;OOS?
  1. .S SDIN=SDDATA(44,SDCL_",",2505,"I"),SDRN=SDDATA(44,SDCL_",",2506,"I")
  1. .Q:$$INACT(SDIN,SDRN)
  1. .S SDCLN=SDDATA(44,SDCL_",",.01,"E") ;clinic name
  1. .;look for existing to allow this post-init to be re-entrant
  1. .S SDRESH=0 F S SDRESH=$O(^SDEC(409.831,"ALOC",SDCL,SDRESH)) Q:SDRESH'>0 D Q:+SDFOUND
  1. ..S SDRES11=$$GET1^DIQ(409.831,SDRESH_",",.012,"I")
  1. ..I $P(SDRES11,";",2)="SC(",$P(SDRES11,";",1)=SDCL S SDFOUND=1
  1. .I +SDFOUND D CHKC(SDCL,SDRESH) Q
  1. .S SDRESH=$O(^SDEC(409.831,"B",$$UP^XLFSTR(SDCLN),0)) ;look for existing SDEC RESOURCE id with clinic name
  1. .I SDRESH'="" Q
  1. .S SDRESH="+1"
  1. .K SDFDA,SDIEN,SDMSG
  1. .S SDFDA=$NA(SDFDA(409.831,SDRESH_","))
  1. .S @SDFDA@(.01)=SDCLN
  1. .S @SDFDA@(.012)=SDCL_";SC("
  1. .S @SDFDA@(.015)=$E($$NOW^XLFDT,1,12)
  1. .S @SDFDA@(.016)=DUZ
  1. .I SDDATA(44,SDCL_",",2505,"I")'="" S @SDFDA@(.021)=SDDATA(44,SDCL_",",2505,"I")
  1. .I SDDATA(44,SDCL_",",2506,"I")'="" S @SDFDA@(.025)=SDDATA(44,SDCL_",",2506,"I")
  1. .S SDTS=SDDATA(44,SDCL_",",1917,"I") S @SDFDA@(.03)=$S(SDTS=5:5,SDTS=6:10,SDTS=4:15,SDTS=3:20,SDTS=2:30,SDTS=45:15,1:60) ;time scale
  1. .S @SDFDA@(.04)=SDCL
  1. .D UPDATE^DIE("","SDFDA","SDIEN","SDMSG")
  1. .I $D(SDMSG) W !,"RESCLIN: Unable to store clinic "_SDCL_" in resource." Q
  1. .S SDRESH=SDIEN(1)
  1. .;get letter text
  1. .S SDLET=SDDATA(44,SDCL_",",2509,"I")
  1. .D RESLET(SDLET,.SDWP)
  1. .I $D(SDWP) D WP^DIE(409.831,SDRESH_",",1,"","SDWP")
  1. .;get no show letter
  1. .S SDLET=SDDATA(44,SDCL_",",2508,"I")
  1. .D RESLET(SDLET,.SDWP)
  1. .I $D(SDWP) D WP^DIE(409.831,SDRESH_",",1201,"","SDWP")
  1. .;get clinic cancellation letter
  1. .S SDLET=SDDATA(44,SDCL_",",2510,"I")
  1. .D RESLET(SDLET,.SDWP)
  1. .I $D(SDWP) D WP^DIE(409.831,SDRESH_",",1301,"","SDWP")
  1. Q
  1. RESLET(SDLET,SDWP) ;get letter text
  1. ;INPUT:
  1. ; SDLET - Letter ID pointer to LETTER file 407.5
  1. ;RETURN
  1. ; .SDWP - Word Processor array used to store text using WP^DIE
  1. N SDMSG,SDWPI,SDWPJ,SDWP2,SDWP3,X
  1. S X=$$GET1^DIQ(407.5,SDLET_",",2,"","SDWP2","SDMSG")
  1. Q:$D(SDMSG)
  1. S X=$$GET1^DIQ(407.5,SDLET_",",3,"","SDWP3","SDMSG")
  1. S SDWPI=0
  1. S SDWPJ="" F S SDWPJ=$O(SDWP2(SDWPJ)) Q:SDWPJ="" S SDWPI=SDWPI+1 S SDWP(SDWPI)=SDWP2(SDWPJ)
  1. S SDWPJ="" F S SDWPJ=$O(SDWP3(SDWPJ)) Q:SDWPJ="" S SDWPI=SDWPI+1 S SDWP(SDWPI)=SDWP3(SDWPJ)
  1. Q
  1. INACT(SDIN,SDRN) ;
  1. ;0=ACTIVATE
  1. ;1=INACTIVE
  1. N NOW,RET
  1. S RET=0
  1. S NOW=$P($$NOW^XLFDT,".",1)
  1. S SDIN=$P($G(SDIN),".",1)
  1. S SDRN=$P($G(SDRN),".",1)
  1. Q:SDIN="" 0 ;no inactive date
  1. Q:NOW<SDIN 0 ;inactive date still in future
  1. I SDIN'>NOW D
  1. .;MGH added one more check on dates
  1. .S RET=$S(SDRN="":1,SDRN'>NOW:0,SDRN>SDIN:0,1:1)
  1. Q RET