SDRRUTL ;10N20/MAH;Recall Reminder-Clinic Utilities;01/18/2008 11:32
;;5.3;PIMS;**1016**;JUN 30, 2012;Build 20
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
;
SDRRUTL ;10N20/MAH;Recall Reminder-Clinic Utilities;01/18/2008 11:32
+1 ;;5.3;PIMS;**1016**;JUN 30, 2012;Build 20
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 ;
