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