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

SDRRUTL.m

Go to the documentation of this file.
  1. SDRRUTL ;10N20/MAH - UTILITIES FOR RECALL REMINDERS ;FEB 04, 2016
  1. ;;5.3;Scheduling;**536,571,582,643,648**;Aug 13, 1993;Build 3
  1. ASKDIV(SDRRDIV) ;
  1. N DIC,X,Y,I,DUOUT,DTOUT
  1. K SDRRDIV
  1. S SDRRDIV=0
  1. W !
  1. S DIC("A")="Select Medical Center Division: All// "
  1. S DIC="^DG(40.8,"
  1. S DIC(0)="AEQMN"
  1. F D Q:Y=-1
  1. . D ^DIC Q:Y=-1
  1. . S SDRRDIV(+Y)=$P(Y,U,2)
  1. . S DIC("A")="Another Medical Center Division: "
  1. Q:$D(DTOUT)!$D(DUOUT)
  1. S I=0
  1. I $O(SDRRDIV(0)) D Q
  1. . F S I=$O(SDRRDIV(I)) Q:'I S SDRRDIV=SDRRDIV+1
  1. F S I=$O(^DG(40.8,I)) Q:'I S SDRRDIV(I)=$P(^(I,0),U),SDRRDIV=SDRRDIV+1
  1. Q
  1. ASKSTOP(SDRRSC,SDRRST,SDRRND) ;
  1. N DIC,X,Y,I,DUOUT,DTOUT,SDRRREC
  1. K SDRRSC
  1. S SDRRSC=0
  1. W !
  1. S DIC("A")="Select Clinic Stop Code: All// "
  1. S DIC="^DIC(40.7,"
  1. S:$G(SDRRST) DIC("S")="N SDRRXD S SDRRXD=$P(^(0),U,3) I 'SDRRXD!(SDRRXD'<SDRRST)"
  1. S DIC(0)="AEQMZ"
  1. F D Q:Y=-1
  1. . D ^DIC Q:Y=-1
  1. . S SDRRSC(+Y)=$P(Y(0),U,2)
  1. . S DIC("A")="Another Clinic Stop Code: "
  1. Q:$D(DTOUT)!$D(DUOUT)
  1. S I=0
  1. I $O(SDRRSC(0)) D Q
  1. . F S I=$O(SDRRSC(I)) Q:'I S SDRRSC=SDRRSC+1
  1. F S I=$O(^DIC(40.7,I)) Q:'I S SDRRREC=^(I,0) D
  1. . Q:$P(SDRRREC,U,3)<SDRRST
  1. . S SDRRSC(I)=$P(SDRRREC,U),SDRRSC=SDRRSC+1
  1. Q
  1. ASKCLIN(SDRRCLIN,SDRRDIV,SDRRST,SDRRND) ;
  1. N DIR,X,Y,DIRUT
  1. K SDRRCLIN
  1. S SDRRCLIN=0
  1. W !
  1. S DIR(0)="Y"
  1. S DIR("A")="All Clinics"
  1. S DIR("B")="No"
  1. D ^DIR Q:$D(DIRUT)
  1. I Y S SDRRCLIN="ALL" Q
  1. D ASKRANGE^SDRRUTL1(.SDRRCLIN,.SDRRDIV,.SDRRST,.SDRRND)
  1. Q
  1. DELIM() ;
  1. N DIR,X,Y,DIRUT
  1. S DIR(0)="Y"
  1. S DIR("A")="Delimited Output"
  1. S DIR("B")="No"
  1. D ^DIR Q:$D(DIRUT) -1
  1. Q Y
  1. REVERSE(SDRRST,SDRRND) ; Given starting and ending dates return reverse starting and ending dates
  1. N SDRRRST,SDRRRND
  1. S SDRRRST=9999999-SDRRST+.9999
  1. S SDRRRND=9999999-SDRRND
  1. S SDRRST=SDRRRND
  1. S SDRRND=SDRRRST
  1. Q
  1. DRANGE(SDRRST,SDRRND,SDRRSTX,SDRRNDX,SDRRABORT,SDRRMIN,SDRRMAX,SDRRFUTR) ;
  1. ; Set SDRRFUTR=1 if dates in the future are OK.
  1. N DIR,DIRUT,X,Y
  1. I $G(SDRRFUTR) S DIR(0)="D^"_$G(SDRRMIN)_":"_$G(SDRRMAX)_":AEFX"
  1. E S DIR(0)="D^"_$G(SDRRMIN)_":"_$G(SDRRMAX,DT)_":AEPX"
  1. S DIR("A")="Enter start date"
  1. I $D(SDRRST) D
  1. . S SDRRSTX=$$FMTE^XLFDT(SDRRST,5)
  1. . S DIR("B")=SDRRSTX
  1. D ^DIR I $D(DIRUT) S SDRRABORT=1 Q
  1. S SDRRST=Y
  1. K DIR
  1. I $G(SDRRFUTR) S DIR(0)="D^"_SDRRST_":"_$G(SDRRMAX)_":AEFX"
  1. E S DIR(0)="D^"_SDRRST_":"_$G(SDRRMAX,DT)_":AEPX"
  1. S DIR("A")="Enter end date"
  1. I $D(SDRRND) D
  1. . S SDRRNDX=$$FMTE^XLFDT(SDRRND,5)
  1. . S DIR("B")=SDRRNDX
  1. D ^DIR I $D(DIRUT) S SDRRABORT=1 Q
  1. S SDRRND=Y
  1. S SDRRNDX=$$FMTE^XLFDT(SDRRND,2)
  1. S SDRRSTX=$$FMTE^XLFDT(SDRRST,2)
  1. Q
  1. ASKDATE(SDRRST,SDRRSTX,SDRRABORT,SDRRMIN,SDRRMAX,SDRRFUTR) ;
  1. N DIR,DIRUT,X,Y
  1. I $G(SDRRFUTR) S DIR(0)="D^"_$G(SDRRMIN)_":"_$G(SDRRMAX)_":AEFX"
  1. E S DIR(0)="D^"_$G(SDRRMIN)_":"_$G(SDRRMAX,DT)_":AEPX"
  1. S DIR("A")="Enter start date"
  1. I $D(SDRRST) D
  1. . S SDRRSTX=$$FMTE^XLFDT(SDRRST,2)
  1. . S DIR("B")=SDRRSTX
  1. D ^DIR I $D(DIRUT) S SDRRABORT=1 Q
  1. S SDRRST=Y
  1. S SDRRSTX=$$FMTE^XLFDT(SDRRST,2)
  1. Q
  1. FYRANGE(SDRRST,SDRRND,SDRRSTX,SDRRNDX,SDRRABORT,SDRRMIN,SDRRMAX) ;
  1. N SDRRMAXFY,SDRRFRFY,SDRRTOFY
  1. S (SDRRMAXFY,SDRRTOFY)=$$FY($$FMADD^XLFDT($E(DT,1,5)_"01",-1)) ; FY of last month
  1. S SDRRFRFY=$$ASKFY($G(SDRRMIN),$G(SDRRMAX),,"From")
  1. I SDRRFRFY=0 S SDRRABORT=1 Q
  1. I SDRRFRFY'=SDRRMAXFY D Q:SDRRABORT
  1. . S SDRRTOFY=$$ASKFY($P(SDRRFRFY,U,3),$G(SDRRMAX),+$P(SDRRMAXFY," ",2),"Through")
  1. . I SDRRTOFY=0 S SDRRABORT=1
  1. S SDRRST=$P(SDRRFRFY,U,2)
  1. S SDRRND=$P(SDRRTOFY,U,3)
  1. S SDRRSTX=$$FMTE^XLFDT($E(SDRRST,1,5)_"01",2)
  1. S SDRRNDX=$$FMTE^XLFDT($$FMADD^XLFDT($E(SDRRND,1,5)_"01",-1),2)
  1. S SDRRSTX("FY")=$P(SDRRFRFY,U)
  1. S SDRRNDX("FY")=$P(SDRRTOFY,U)
  1. Q
  1. ASKFY(SDRRMIN,SDRRMAX,SDRRDEF,SDRRPRMPT) ; Function asks user which FY.
  1. N DIR,X,Y,DIRUT,SDRRFY
  1. S DIR("A")=$G(SDRRPRMPT,"Select")_" FY ("
  1. I '$G(SDRRMAX) D
  1. . S SDRRMAX=$$FMADD^XLFDT($E(DT,1,5)_"01",-1) ; last month
  1. . S SDRRMAX=$E($P($$FY(SDRRMAX),U,3),1,3)_"0000"
  1. I $G(SDRRMIN) S DIR("A")=DIR("A")_($E(SDRRMIN,1,3)+1700)_" "
  1. S DIR("A")=DIR("A")_"through "_($E(SDRRMAX,1,3)+1700)_"): "
  1. S DIR(0)="DA^"_$G(SDRRMIN)_":"_SDRRMAX_":AEM"
  1. S DIR("B")=$$FMTE^XLFDT($G(SDRRDEF,SDRRMAX))
  1. D ^DIR I $D(DIRUT) Q 0
  1. S SDRRFY=$$FY(Y)
  1. W " ",$P(SDRRFY,U)
  1. Q SDRRFY
  1. FY(SDRRDT) ; Pass in a date (default = today's date),
  1. ; and this function returns what FY we are in,
  1. ; followed by the FY start date and FY end date.
  1. ; ie. S X=$$FY^SDRRUTL(3050208) results in X="FY 2005^3041000^3051000"
  1. N SDRRST,SDRRND
  1. S:'$D(SDRRDT) SDRRDT=DT
  1. S SDRRST=$E(SDRRDT,1,3)-($E(SDRRDT,4,5)<10)_"1000"
  1. S SDRRND=$E(SDRRST,1,3)+1_"1000"
  1. Q "FY "_(1701+$E(SDRRST,1,3))_U_SDRRST_U_SDRRND
  1. ASKMON(SDRRMON) ; Function asks user which month.
  1. ; SDRRMON - (optional) default month
  1. N DIR,X,Y,DIRUT,SDRRDT
  1. S DIR("A")="Select Month"
  1. I $D(SDRRMON) S SDRRDT=SDRRMON
  1. E D
  1. . S SDRRDT=$$FMADD^XLFDT($E(DT,1,5)_"01",-1) ; last month
  1. . S SDRRDT=$E(SDRRDT,1,5)_"00"
  1. S DIR(0)="D^:"_SDRRDT_":AEM"
  1. S DIR("B")=$$FMTE^XLFDT(SDRRDT)
  1. D ^DIR I $D(DIRUT) Q 0
  1. Q Y
  1. MON(SDRRDT) ; Pass in a date (default = today's date),
  1. ; and this function returns the first and last dates of the month.
  1. N SDRRMST,SDRRMND
  1. S:'$D(SDRRDT) SDRRDT=DT
  1. S SDRRMST=$E(SDRRDT,1,5)_"01"
  1. S SDRRMND=$$SCH^XLFDT("1M(1)",SDRRMST)\1
  1. Q SDRRMST_U_SDRRMND
  1. BDAY ;
  1. N GDAYS,JDAYS,YR1DAYS
  1. S GDAYS=$$FMDIFF^XLFDT(3050830,3050628) W !,"GDAYS=",GDAYS
  1. S JDAYS=$$FMDIFF^XLFDT(3050830,3050811) W !,"JDAYS=",JDAYS
  1. S YR1DAYS=365-GDAYS-JDAYS W !,"YR1DAYS=",YR1DAYS
  1. W !,"99th Birthday= ",$$FMADD^XLFDT(3050830,YR1DAYS\4)
  1. W !,"100th Birthday=",$$FMADD^XLFDT(3050830,(YR1DAYS+365)\4)
  1. W !,"101st Birthday=",$$FMADD^XLFDT(3050830,YR1DAYS+730\4)
  1. Q
  1. ;
  1. SCREEN() ;SD*571 for new RRs, screen provider for key and status
  1. N KEY,VALUE
  1. S SDIEN="",SDIEN=DA
  1. S SDFLAG=0
  1. I '$P($G(^SD(403.54,+X,0)),U,7),$P($G(^(0)),U,6)="A" S SDFLAG=1 Q SDFLAG ;allow selection, provider has no key and is active
  1. I $P($G(^SD(403.54,+X,0)),U,6)="I" D MSG1 Q SDFLAG ;do not allow, provider is inactive
  1. I $P($G(^SD(403.54,+X,0)),U,7) S KEY=$P(^(0),U,7) D
  1. .S VALUE=$$LKUP^XPDKEY(KEY) K KY D OWNSKEY^XUSRB(.KY,VALUE,DUZ)
  1. .I $G(KY(0))=1 S SDFLAG=1 K KY
  1. I SDFLAG Q SDFLAG ;allow, provider and user both have security key
  1. I 'SDFLAG D MSG2 ;do not allow, provider has key user does not
  1. Q SDFLAG
  1. ;
  1. MSG1 ;SD*571 print Inactive provider warning message to user
  1. W " ??"
  1. W !?10,"Provider selected is Inactive."
  1. W !?10,"Please contact your Recall Coordinator.",!
  1. D:$D(PROV1) FDA Q
  1. Q
  1. ;
  1. MSG2 ;SD*571 print Security Key warning message to user
  1. W " ??"
  1. W !?10,"Provider selected is assigned Security Key"
  1. W !?10,"which you do not hold."
  1. W !?10,"Please contact your Recall Coordinator.",!
  1. D:$D(PROV1) FDA Q
  1. Q
  1. ;
  1. FDA ;SD*571 insure original provider pointer is back in 403.5 record
  1. Q:'$D(PROV1)
  1. S (FDA,SDFLD)=""
  1. S SDFLD=4,FDA(403.5,SDIEN_",",SDFLD)=PROV1
  1. D FILE^DIE("","FDA")
  1. D CLEAN^DILF
  1. K FDA,SDFLD,SDIEN
  1. S SDFLAG="" ;null indicates edit so ^DIK will not be called at exit
  1. Q
  1. ;
  1. SCREEN1() ; SD*582 screen clinic for add/edits - don't allow if clinic
  1. ; type is not clinic OR
  1. ; already inactive OR
  1. ; scheduled to be inactivated on OR
  1. ; before recall date OR not being reactivated until after selected recall date.
  1. ;Also don't allow clinic if there is not a Recall Letter associated.
  1. ;
  1. N SDNODE,SDRDT,SDIDT
  1. ; SD*648 - Check if clinic type is CLINIC
  1. I $P($G(^SC(+X,0)),U,3)'="C" D Q 0
  1. . W *7,!!,?5,"The type of location assigned is not a clinic, please re-enter it.",!
  1. ;check for RECALL REMINDERS LETTERS entry
  1. I '$O(^SD(403.52,"B",+X,0)) D Q 0 ;alb/sat 643
  1. .W *7,!!,?5,"There is no Recall Reminder Letter defined for clinic "_$$GET1^DIQ(44,+X_",",.01)_".",!
  1. ; Active if clinic is not inactive
  1. I '$G(^SC(+X,"I")) Q 1
  1. ; Get selected recall date
  1. S SDRDT=$P(^SD(403.5,DA,0),U,6)
  1. ; Check if clinic is inactive
  1. S:$G(^SC(+X,"I")) SDNODE=$G(^("I"))
  1. ; Active if inactivate date after recall date
  1. I $P(SDNODE,U,2)="" I $P(SDNODE,U,1)>SDRDT Q 1
  1. ; Inactive if inactivate date equal or prior to recall date
  1. I $P(SDNODE,U,2)="" I $P(SDNODE,U,1)=SDRDT!($P(SDNODE,U,1)<SDRDT) D Q 0
  1. . S SDIDT=$P(SDNODE,U,1),SDIDT=$$FMTE^XLFDT(SDIDT)
  1. . W *7,!!,?5,"Clinic Inactive effective "_SDIDT_".",!
  1. ; Active if reactivate date equal or prior to recall date
  1. I $P(SDNODE,U,2)'="" I $P(SDNODE,U,2)=SDRDT!($P(SDNODE,U,2)<SDRDT) Q 1
  1. ; Inactive if reactivate date after recall date
  1. I $P(SDNODE,U,2)'="" I $P(SDNODE,U,2)>SDRDT D Q 0
  1. . S SDIDT=$P(SDNODE,U,2),SDIDT=$$FMTE^XLFDT(SDIDT)
  1. . W *7,!!,?5,"Clinic Inactive until "_SDIDT_".",!
  1. Q 1