RTSM81 ;PKE/ISC-ALBANY-Retirement Data Routine; ; 11/7/90 ;
;;v 2.0;Record Tracking;;10/22/91
ASK D DIP W !!,"Record Type Retirement Parameters:",!,"----------------------------------"
DIE S DIC("A")="Select RECORD TYPE: ",DIC="^DIC(195.2,",DIC(0)="AEMQ",DIC("S")="I $P(^(0),U,3)=+RTAPL" D ^DIC K DIC G Q:X="^" I Y>0 S DA=+Y,DR="[RT RETIREMENT PROFILE]",DIE="^DIC(195.2," D ^DIE K DE,DQ W ! G DIE
W !!,"Overall Retirement Parameters:",!,"------------------------------" S DA=+RTAPL,DR="25",DIE="^DIC(195.1," D ^DIE K DE,DQ G Q:$D(Y)
S X=^DIC(195.1,+RTAPL,2) I $P(X,"^",5)'="y" W !!?5,*7,"No records will be retired!" K RTERM Q
;
W ! S DIR(0)="YO",DIR("B")="NO",DIR("A")=" Is it ok to continue"
S DIR("?")=" Enter 'Y' to continue"
D ^DIR I $D(DUOUT)!($D(DTOUT))!('Y) K DIR Q
W ! S DIR(0)="YO",DIR("B")="YES",DIR("A")="Use terminal digit scan"
S DIR("?")="^D H2^RTSM81"
D ^DIR I $D(DUOUT)!($D(DTOUT)) K DIR Q
S RTERM="" I 'Y S RTERM="NO" W !!," 'Record Retirement Pull lists' will be generated by",!," searching all Records for ",$P($P(RTAPL,"^"),";",2) Q
;
W !!," 'Record Retirement Pull lists' will be generated using",!," terminal digits to select a range of Records " Q
;
Q K DIR,DIC,DE,DQ Q
;
START ;K RTFLAGS,RTT S (RTLSTQ,RTLSTP)=0 F I=10,8,12 S $P(RTFLAGS,"^",I)=$P(^DIC(195.4,1,0),"^",I)="y"
;
;F RTYPE=0:0 S RTYPE=$O(^DIC(195.2,RTYPE)) Q:'RTYPE I $D(^(RTYPE,0)) S RTYPE0=^(0) D SET:$P(RTYPE0,"^",18)="y"
;Q
DIP W !!?5,"...compiling retirement profile" S IOP="HOME",DIC="^DIC(195.2,",(BY,FLDS)="[RT RETIREMENT PROFILE]",L=0,DIS(0)="I $P(^DIC(195.2,D0,0),U,3)=+RTAPL" K DTOUT D EN1^DIP K DIC,FLDS,BY,L,TO,FR,IOP Q
Q
FLAG S RTAA=+RTAPL
S RTB=+RTFR
S RTA=+RTAPL
D DAT,TYP Q
;
DAT D NOW^%DTC S %I(1)=%I(1)+1 I %I(1)>12 S %I(1)=1,%I(3)=%I(3)+1
S X=$S(%I(1)?1N:"0"_%I(1),1:%I(1))_"01"_$E(%I(3),2,3),%DT="F" D ^%DT
K %DT,%I S RTTM=$E(Y,1,5)_"01",RTTMM="["_$E(Y,4,5)_"/01/"_$E(Y,2,3)_"]"
Q
TYP S RTLSTM=0 F RTYPE=0:0 S RTYPE=$O(^DIC(195.2,RTYPE)) Q:'RTYPE I $D(^(RTYPE,0)) S RTYPE0=^(0) I $P(RTYPE0,"^",3)=+RTAPL S RTFLAG(RTYPE)=0 I $D(^(1)) D SET:$P(^(1),"^",2)="y"
K RTYPE,RTYPE0
Q
;determine from the 1st of next month, rttm
SET ;
S X1=RTTM,X2=-$S($P(RTYPE0,"^",19):$P(RTYPE0,"^",19),1:"") D C^%DTC S RTFLAG(RTYPE)=X S:RTLSTM'>X RTLSTM=X Q
;S Y=X D D^DIQ S RTFLAGS(RTYPE)=$J($P(RTYPE0,"^",2)_" Cutoff = "_Y,26)
Q
BDAT S X2=-Y D DAT S X1=RTTM D C^%DTC S Y=X D D^DIQ W Y Q
;
HDR W:$E(IOST,1,2)'="C-" @IOF W !?5,"Generating ",RTDESC,!!
;W !?5 F N=0:0 S N=$O(RTFLAGS(N)) Q:'N W:$X>55 !?5 W RTFLAGS(N)," "
;W !! K RTFLAGS Q
Q
H1 W !!?5,"You may select a single terminal digit like `11'",!?8,"or a range of terminal digits like `5-30'"
Q
H2 W !!?5,"Enter 'Y' to look for inactive records by terminal digit"
W !?5,"Enter 'N' to look for inactive records by record number" Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRTSM81 2873 printed Oct 16, 2024@18:35:36 Page 2
RTSM81 ;PKE/ISC-ALBANY-Retirement Data Routine; ; 11/7/90 ;
+1 ;;v 2.0;Record Tracking;;10/22/91
ASK DO DIP
WRITE !!,"Record Type Retirement Parameters:",!,"----------------------------------"
DIE SET DIC("A")="Select RECORD TYPE: "
SET DIC="^DIC(195.2,"
SET DIC(0)="AEMQ"
SET DIC("S")="I $P(^(0),U,3)=+RTAPL"
DO ^DIC
KILL DIC
if X="^"
GOTO Q
IF Y>0
SET DA=+Y
SET DR="[RT RETIREMENT PROFILE]"
SET DIE="^DIC(195.2,"
DO ^DIE
KILL DE,DQ
WRITE !
GOTO DIE
+1 WRITE !!,"Overall Retirement Parameters:",!,"------------------------------"
SET DA=+RTAPL
SET DR="25"
SET DIE="^DIC(195.1,"
DO ^DIE
KILL DE,DQ
if $DATA(Y)
GOTO Q
+2 SET X=^DIC(195.1,+RTAPL,2)
IF $PIECE(X,"^",5)'="y"
WRITE !!?5,*7,"No records will be retired!"
KILL RTERM
QUIT
+3 ;
+4 WRITE !
SET DIR(0)="YO"
SET DIR("B")="NO"
SET DIR("A")=" Is it ok to continue"
+5 SET DIR("?")=" Enter 'Y' to continue"
+6 DO ^DIR
IF $DATA(DUOUT)!($DATA(DTOUT))!('Y)
KILL DIR
QUIT
+7 WRITE !
SET DIR(0)="YO"
SET DIR("B")="YES"
SET DIR("A")="Use terminal digit scan"
+8 SET DIR("?")="^D H2^RTSM81"
+9 DO ^DIR
IF $DATA(DUOUT)!($DATA(DTOUT))
KILL DIR
QUIT
+10 SET RTERM=""
IF 'Y
SET RTERM="NO"
WRITE !!," 'Record Retirement Pull lists' will be generated by",!," searching all Records for ",$PIECE($PIECE(RTAPL,"^"),";",2)
QUIT
+11 ;
+12 WRITE !!," 'Record Retirement Pull lists' will be generated using",!," terminal digits to select a range of Records "
QUIT
+13 ;
Q KILL DIR,DIC,DE,DQ
QUIT
+1 ;
START ;K RTFLAGS,RTT S (RTLSTQ,RTLSTP)=0 F I=10,8,12 S $P(RTFLAGS,"^",I)=$P(^DIC(195.4,1,0),"^",I)="y"
+1 ;
+2 ;F RTYPE=0:0 S RTYPE=$O(^DIC(195.2,RTYPE)) Q:'RTYPE I $D(^(RTYPE,0)) S RTYPE0=^(0) D SET:$P(RTYPE0,"^",18)="y"
+3 ;Q
DIP WRITE !!?5,"...compiling retirement profile"
SET IOP="HOME"
SET DIC="^DIC(195.2,"
SET (BY,FLDS)="[RT RETIREMENT PROFILE]"
SET L=0
SET DIS(0)="I $P(^DIC(195.2,D0,0),U,3)=+RTAPL"
KILL DTOUT
DO EN1^DIP
KILL DIC,FLDS,BY,L,TO,FR,IOP
QUIT
+1 QUIT
FLAG SET RTAA=+RTAPL
+1 SET RTB=+RTFR
+2 SET RTA=+RTAPL
+3 DO DAT
DO TYP
QUIT
+4 ;
DAT DO NOW^%DTC
SET %I(1)=%I(1)+1
IF %I(1)>12
SET %I(1)=1
SET %I(3)=%I(3)+1
+1 SET X=$SELECT(%I(1)?1N:"0"_%I(1),1:%I(1))_"01"_$EXTRACT(%I(3),2,3)
SET %DT="F"
DO ^%DT
+2 KILL %DT,%I
SET RTTM=$EXTRACT(Y,1,5)_"01"
SET RTTMM="["_$EXTRACT(Y,4,5)_"/01/"_$EXTRACT(Y,2,3)_"]"
+3 QUIT
TYP SET RTLSTM=0
FOR RTYPE=0:0
SET RTYPE=$ORDER(^DIC(195.2,RTYPE))
if 'RTYPE
QUIT
IF $DATA(^(RTYPE,0))
SET RTYPE0=^(0)
IF $PIECE(RTYPE0,"^",3)=+RTAPL
SET RTFLAG(RTYPE)=0
IF $DATA(^(1))
if $PIECE(^(1),"^",2)="y"
DO SET
+1 KILL RTYPE,RTYPE0
+2 QUIT
+3 ;determine from the 1st of next month, rttm
SET ;
+1 SET X1=RTTM
SET X2=-$SELECT($PIECE(RTYPE0,"^",19):$PIECE(RTYPE0,"^",19),1:"")
DO C^%DTC
SET RTFLAG(RTYPE)=X
if RTLSTM'>X
SET RTLSTM=X
QUIT
+2 ;S Y=X D D^DIQ S RTFLAGS(RTYPE)=$J($P(RTYPE0,"^",2)_" Cutoff = "_Y,26)
+3 QUIT
BDAT SET X2=-Y
DO DAT
SET X1=RTTM
DO C^%DTC
SET Y=X
DO D^DIQ
WRITE Y
QUIT
+1 ;
HDR if $EXTRACT(IOST,1,2)'="C-"
WRITE @IOF
WRITE !?5,"Generating ",RTDESC,!!
+1 ;W !?5 F N=0:0 S N=$O(RTFLAGS(N)) Q:'N W:$X>55 !?5 W RTFLAGS(N)," "
+2 ;W !! K RTFLAGS Q
+3 QUIT
H1 WRITE !!?5,"You may select a single terminal digit like `11'",!?8,"or a range of terminal digits like `5-30'"
+1 QUIT
H2 WRITE !!?5,"Enter 'Y' to look for inactive records by terminal digit"
+1 WRITE !?5,"Enter 'N' to look for inactive records by record number"
QUIT
