RTSM8 ;isc-albany/pke-check records for retirement ; 10/1/90 ; 1/7/03 11:51am
;;2.0;Record Tracking;**4,14,30,34**;10/22/91
D ASK^RTSM81 I '$D(RTERM) D Q10 Q
I RTERM="NO" D GO,Q10 Q
; file 194.3 only needed if user chooses to do a terminal digit scan
I $D(^RTV(194.3,1,0)),($E($P(^(0),"^",3),1,3))'=($E(DT,1,3)) DO Q
.W !!,*7,"The RECORD TRACKING SORT GLOBAL file(#194.3) "
.I '$P(^(0),"^",2),'$P(^(0),"^",3) W "needs to be compiled"
.;naked ref rtv(194.3,1,0)
.E I $E($P(^(0),U,2),1,7)=$E(DT,1,7),'$P(^(0),"^",3) W "is currently being compiled" D Q10 Q
.E W "needs additional compiling"
.D CHKQ^RTSM4,Q10
;
K DIR W !
;S DIR("A")="Select a Terminal Digit or range",DIR("B")="1"
S DIR("A",1)="Select a Terminal Digit or range. Although a maximum"
S DIR("A")="of 50 is allowed, we recommend a maximum of 10"
S DIR("B")="1"
S DIR("?")="Enter a single terminal digit or a range, maximum 50, "
S DIR("??")="^D H1^RTSM81"
S DASH="-",COM=""",""",DAS="""-"""
S IF="K:X["_COM_" X I $D(X),X["_DAS_",$P(X,DASH,2)-$P(X,DASH,1)>49 K X"
S DIR(0)="L^0:99"
S DIR(0)=DIR(0)_"^"_IF
D ^DIR I $D(DUOUT)!($D(DTOUT)) D Q10 Q
F I=1:1 Q:'$L($P(Y,",",I)) I $L($P(Y,",",I))=1 S $P(Y,",",I)="0"_$P(Y,",",I)
S RTERM=Y K X,Y
GO W !!
S RTDESC="Record Retirement Pull List(s) ["_$P($P(RTAPL,"^"),";",2)_"]",RTVAR="RTDESC^RTERM^RTAPL^RTFR",RTPGM="START^RTSM8" S IOP="HOME" D ^%ZIS K IOP D ZIS^RTUTL
I POP D Q10 Q
W !!
START S (RTAA,RTA)=+RTAPL,RTB=+RTFR,RTLAST=$P(^RT(0),"^",3)
;check if mas or rad
S RTDPT=1 I RTA'=+^DIC(195.4,1,"MAS"),RTA'=+^("RAD") S RTDPT=0
D FLAG^RTSM81
S (RTCOUNT,RTHIT)=0 S CR=$C(13,10),MOD=100 I $E(IOST,1,2)="C-" S CR=$C(13),MOD=10
K RTR I RTERM="NO" S RTDPT=0 F RTR=0:0 S RTR=$O(^RT(RTR)) Q:'RTR I $D(^(RTR,0)) S RTEE=$P(^(0),"^") D RCHECK
I $D(RTR) D Q10 Q
;F RTRM0=1:1 S RTRM=$P(RTERM,",",RTRM0) Q:RTRM="" S RTTD=$S($D(RTSTART):RTSTART,1:RTRM_"0000000") K RTSTART F RTRM1=0:0 S RTTD=$O(^UTILITY("RTDPTSORT",RTTD)) Q:$E(RTTD,1,2)'=RTRM!(RTTD="") S DFN=+$O(^(RTTD,0)) I DFN D TDCHECK
;
F RTRM0=1:1 S RTRM=$P(RTERM,",",RTRM0) Q:RTRM="" DO
.S RTTD=$S($D(RTSTART):RTSTART,1:RTRM_"0000000") K RTSTART
.S RTRM1=0
.FOR S RTTD=$O(^RTV(194.3,1,1,"AC",RTTD)) Q:$E(RTTD,1,2)'=RTRM!(RTTD="") DO
. .S DFN=0
. .F S DFN=$O(^RTV(194.3,1,1,"AC",RTTD,DFN)) Q:'DFN D TDCHECK
;
K RTRM0,RTRM1,RTNME,RTNME0,RTRM,RTTD,DFN,RTFLAG,RTWND D Q10 Q
;
TDCHECK S RTEE=DFN_";DPT(" K RTPHIST
RCHECK I $D(^RT("AA",RTAA,RTEE)) F RTT=0:0 S RTT=$O(^RT("AA",RTAA,RTEE,RTT)) Q:'RTT D REC
Q
REC I 'RTCOUNT D HDR^RTSM81
I RTCOUNT#MOD=0 W CR_$J(RTCOUNT,10)_" Records Checked ",$J(RTHIT,6)," Inactive Records ",$S(RTERM'="NO":$J(RTRM,5)_" tdigits",1:$J(RTR,8)_" rec #")
S RTCOUNT=RTCOUNT+1
I RTDPT,$D(RTPHIST(1)) Q
I $D(^RT("AR","t",RTT)) Q
I $D(^RT("AR","r",RTT)) Q
Q:'$D(^RT(RTT,0)) Q:'$D(^("CL")) S RT0=^(0),RTCL=^("CL")
Q:$P(RT0,"^",4)'=+RTAPL
; type of record, date/time charged, ok to retire
S RTI=$P(RT0,"^",3) I $S('$D(RTFLAG(RTI)):1,'RTFLAG(RTI):1,1:0) Q
S RTDT=$P(RTCL,"^",6)
;naked ref to ^rt(rtt,i) tag rec+6
I $D(^("I")),^("I") Q
;
I RTDPT,'$D(RTPHIST) D DPTCHK S RTPHIST($T)="" I $T Q
;
;only if not mas,rad
I 'RTDPT,RTDT,RTDT'<RTFLAG(RTI) Q
;
;creat list by current location, home location, unknown
S RTP=$P(RTCL,"^",5) I 'RTP S RTP=$P(RT0,"^",6) I 'RTP S (Y,RTP)="LOCATION UNKNOWN" IF 1
E S Y=RTP D BOR^RTB I Y="UNKNOWN" S Y="LOCATION"_Y
S Y="RR "_Y
;
;
K RTP
S RTHIT=RTHIT+1
S RTB=+RTFR,RT=RTT
;have RTTM, Y
S RTE=RTEE
S RTPLTY=3,(RTQDT,X)=RTTM,RTPN=$P(Y,"^")_" ["_$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)_"]"
;
PUL S X=RTB,A=+RTAA K RTA,RTSD,RTDIV D INST1^RTUTL G Q10:'$D(RTINST) S RTDIV=RTINST
D RTSD
K RTBKGRD Q
;
RTSD K RTPAR S RTB=$P(^RTV(195.9,RTB,0),"^"),RTA=+RTAA D CHK K RTA,RTQ D PULL^RTQ2,CHK1 I '$D(RTPAR),$D(RTQ) S RTPAR=RTQ
Q
CHK S Y=+$O(^RTV(195.9,"ABOR",RTB,RTA,0)) D SET^RTDPA3:'Y S RTB=Y Q
;
CHK1 ;
; RT*1*34 - this shortcut uses "AC" xref instead of "C"
S R=0
I $D(^RTV(190.1,"AC",RT,RTTM)) F R=0:0 S R=$O(^RTV(190.1,"AC",RT,RTTM,R)) Q:'R I $D(^RTV(190.1,"ABOR",RTB,R)),$D(^RTV(190.1,R,0)) S Q0=^(0) I $P(Q0,U)=RT,$P(Q0,U,4)=RTTM,$P(Q0,U,5)=RTB,$P(Q0,U,10)=RTPULL Q
I 'R D SET^RTQ
;F R=0:0 S R=$O(^RTV(190.1,"C",RTTM,R)) Q:'R D INFO I $D(^RTV(190.1,"ABOR",RTB,R)),$D(^RTV(190.1,R,0)) S Q0=^(0) I $P(Q0,"^")=RT,$P(Q0,"^",4)=RTTM,$P(Q0,"^",5)=RTB,$P(Q0,"^",10)=RTPULL Q
;I 'R D SET^RTQ
Q
INFO ;I R#100=0,'$D(ZTSK) W "."
Q
Q10 K RTLSTM,RADPT,RTLOAD,RTMES1,RTERM,DIC,DIE,DR,DA,DAS,DASH,IF,DIR,COM,J,Z
K RTCOUNT,RTHIT,RTLAST,R,RT0,RTAA,RTINST,RTPGM,RTVAR,CR,MOD,RTPHIST
K Q0,RTDPT,RT,RTB,RTCL,RTDT,RTE,RTEE,RTERM,RTERM0,RTI,RTLOAD,RTPAR,RTPLTY,RTPN,RTPULL,RTQ,RTQDT,RTRM,RTRM0,RTT,RTTD,RTTM,RTTMM,RTWND,RTXX D CLOSE^RTUTL
Q
DPTCHK ;returns $t=1 if dhcp activity
S RTPHIST=1
FILED I $D(^DPT(DFN,0)),$P(^(0),"^",16)>RTFLAG(RTI) Q
;
INPAT I $D(^DPT(DFN,.1)),$P(^(.1),"^")]"" Q
;
SC I $O(^DPT(DFN,"S",RTFLAG(RTI))) Q
;
SDV ;
N RTZERR I $$EXAE^SDOE(DFN,RTFLAG(RTI)\1+1,9999999,,"RTZERR") Q ;Standalone encounter exists
;
DIS I $O(^DPT(DFN,"DIS",0)),$O(^(0))<(9999999-RTFLAG(RTI)) Q
;
MOV I $O(^DGPM("APID",DFN,0)),$O(^(0))<(9999999-RTFLAG(RTI)) Q
;
S RTPHIST=0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRTSM8 5291 printed Nov 22, 2024@17:44:50 Page 2
RTSM8 ;isc-albany/pke-check records for retirement ; 10/1/90 ; 1/7/03 11:51am
+1 ;;2.0;Record Tracking;**4,14,30,34**;10/22/91
+2 DO ASK^RTSM81
IF '$DATA(RTERM)
DO Q10
QUIT
+3 IF RTERM="NO"
DO GO
DO Q10
QUIT
+4 ; file 194.3 only needed if user chooses to do a terminal digit scan
+5 IF $DATA(^RTV(194.3,1,0))
IF ($EXTRACT($PIECE(^(0),"^",3),1,3))'=($EXTRACT(DT,1,3))
Begin DoDot:1
+6 WRITE !!,*7,"The RECORD TRACKING SORT GLOBAL file(#194.3) "
+7 IF '$PIECE(^(0),"^",2)
IF '$PIECE(^(0),"^",3)
WRITE "needs to be compiled"
+8 ;naked ref rtv(194.3,1,0)
+9 IF '$TEST
IF $EXTRACT($PIECE(^(0),U,2),1,7)=$EXTRACT(DT,1,7)
IF '$PIECE(^(0),"^",3)
WRITE "is currently being compiled"
DO Q10
QUIT
+10 IF '$TEST
WRITE "needs additional compiling"
+11 DO CHKQ^RTSM4
DO Q10
End DoDot:1
QUIT
+12 ;
+13 KILL DIR
WRITE !
+14 ;S DIR("A")="Select a Terminal Digit or range",DIR("B")="1"
+15 SET DIR("A",1)="Select a Terminal Digit or range. Although a maximum"
+16 SET DIR("A")="of 50 is allowed, we recommend a maximum of 10"
+17 SET DIR("B")="1"
+18 SET DIR("?")="Enter a single terminal digit or a range, maximum 50, "
+19 SET DIR("??")="^D H1^RTSM81"
+20 SET DASH="-"
SET COM=""","""
SET DAS="""-"""
+21 SET IF="K:X["_COM_" X I $D(X),X["_DAS_",$P(X,DASH,2)-$P(X,DASH,1)>49 K X"
+22 SET DIR(0)="L^0:99"
+23 SET DIR(0)=DIR(0)_"^"_IF
+24 DO ^DIR
IF $DATA(DUOUT)!($DATA(DTOUT))
DO Q10
QUIT
+25 FOR I=1:1
if '$LENGTH($PIECE(Y,",",I))
QUIT
IF $LENGTH($PIECE(Y,",",I))=1
SET $PIECE(Y,",",I)="0"_$PIECE(Y,",",I)
+26 SET RTERM=Y
KILL X,Y
GO WRITE !!
+1 SET RTDESC="Record Retirement Pull List(s) ["_$PIECE($PIECE(RTAPL,"^"),";",2)_"]"
SET RTVAR="RTDESC^RTERM^RTAPL^RTFR"
SET RTPGM="START^RTSM8"
SET IOP="HOME"
DO ^%ZIS
KILL IOP
DO ZIS^RTUTL
+2 IF POP
DO Q10
QUIT
+3 WRITE !!
START SET (RTAA,RTA)=+RTAPL
SET RTB=+RTFR
SET RTLAST=$PIECE(^RT(0),"^",3)
+1 ;check if mas or rad
+2 SET RTDPT=1
IF RTA'=+^DIC(195.4,1,"MAS")
IF RTA'=+^("RAD")
SET RTDPT=0
+3 DO FLAG^RTSM81
+4 SET (RTCOUNT,RTHIT)=0
SET CR=$CHAR(13,10)
SET MOD=100
IF $EXTRACT(IOST,1,2)="C-"
SET CR=$CHAR(13)
SET MOD=10
+5 KILL RTR
IF RTERM="NO"
SET RTDPT=0
FOR RTR=0:0
SET RTR=$ORDER(^RT(RTR))
if 'RTR
QUIT
IF $DATA(^(RTR,0))
SET RTEE=$PIECE(^(0),"^")
DO RCHECK
+6 IF $DATA(RTR)
DO Q10
QUIT
+7 ;F RTRM0=1:1 S RTRM=$P(RTERM,",",RTRM0) Q:RTRM="" S RTTD=$S($D(RTSTART):RTSTART,1:RTRM_"0000000") K RTSTART F RTRM1=0:0 S RTTD=$O(^UTILITY("RTDPTSORT",RTTD)) Q:$E(RTTD,1,2)'=RTRM!(RTTD="") S DFN=+$O(^(RTTD,0)) I DFN D TDCHECK
+8 ;
+9 FOR RTRM0=1:1
SET RTRM=$PIECE(RTERM,",",RTRM0)
if RTRM=""
QUIT
Begin DoDot:1
+10 SET RTTD=$SELECT($DATA(RTSTART):RTSTART,1:RTRM_"0000000")
KILL RTSTART
+11 SET RTRM1=0
+12 FOR
SET RTTD=$ORDER(^RTV(194.3,1,1,"AC",RTTD))
if $EXTRACT(RTTD,1,2)'=RTRM!(RTTD="")
QUIT
Begin DoDot:2
+13 SET DFN=0
+14 FOR
SET DFN=$ORDER(^RTV(194.3,1,1,"AC",RTTD,DFN))
if 'DFN
QUIT
DO TDCHECK
End DoDot:2
End DoDot:1
+15 ;
+16 KILL RTRM0,RTRM1,RTNME,RTNME0,RTRM,RTTD,DFN,RTFLAG,RTWND
DO Q10
QUIT
+17 ;
TDCHECK SET RTEE=DFN_";DPT("
KILL RTPHIST
RCHECK IF $DATA(^RT("AA",RTAA,RTEE))
FOR RTT=0:0
SET RTT=$ORDER(^RT("AA",RTAA,RTEE,RTT))
if 'RTT
QUIT
DO REC
+1 QUIT
REC IF 'RTCOUNT
DO HDR^RTSM81
+1 IF RTCOUNT#MOD=0
WRITE CR_$JUSTIFY(RTCOUNT,10)_" Records Checked ",$JUSTIFY(RTHIT,6)," Inactive Records ",$SELECT(RTERM'="NO":$JUSTIFY(RTRM,5)_" tdigits",1:$JUSTIFY(RTR,8)_" rec #")
+2 SET RTCOUNT=RTCOUNT+1
+3 IF RTDPT
IF $DATA(RTPHIST(1))
QUIT
+4 IF $DATA(^RT("AR","t",RTT))
QUIT
+5 IF $DATA(^RT("AR","r",RTT))
QUIT
+6 if '$DATA(^RT(RTT,0))
QUIT
if '$DATA(^("CL"))
QUIT
SET RT0=^(0)
SET RTCL=^("CL")
+7 if $PIECE(RT0,"^",4)'=+RTAPL
QUIT
+8 ; type of record, date/time charged, ok to retire
+9 SET RTI=$PIECE(RT0,"^",3)
IF $SELECT('$DATA(RTFLAG(RTI)):1,'RTFLAG(RTI):1,1:0)
QUIT
+10 SET RTDT=$PIECE(RTCL,"^",6)
+11 ;naked ref to ^rt(rtt,i) tag rec+6
+12 IF $DATA(^("I"))
IF ^("I")
QUIT
+13 ;
+14 IF RTDPT
IF '$DATA(RTPHIST)
DO DPTCHK
SET RTPHIST($TEST)=""
IF $TEST
QUIT
+15 ;
+16 ;only if not mas,rad
+17 IF 'RTDPT
IF RTDT
IF RTDT'<RTFLAG(RTI)
QUIT
+18 ;
+19 ;creat list by current location, home location, unknown
+20 SET RTP=$PIECE(RTCL,"^",5)
IF 'RTP
SET RTP=$PIECE(RT0,"^",6)
IF 'RTP
SET (Y,RTP)="LOCATION UNKNOWN"
IF 1
+21 IF '$TEST
SET Y=RTP
DO BOR^RTB
IF Y="UNKNOWN"
SET Y="LOCATION"_Y
+22 SET Y="RR "_Y
+23 ;
+24 ;
+25 KILL RTP
+26 SET RTHIT=RTHIT+1
+27 SET RTB=+RTFR
SET RT=RTT
+28 ;have RTTM, Y
+29 SET RTE=RTEE
+30 SET RTPLTY=3
SET (RTQDT,X)=RTTM
SET RTPN=$PIECE(Y,"^")_" ["_$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)_"]"
+31 ;
PUL SET X=RTB
SET A=+RTAA
KILL RTA,RTSD,RTDIV
DO INST1^RTUTL
if '$DATA(RTINST)
GOTO Q10
SET RTDIV=RTINST
+1 DO RTSD
+2 KILL RTBKGRD
QUIT
+3 ;
RTSD KILL RTPAR
SET RTB=$PIECE(^RTV(195.9,RTB,0),"^")
SET RTA=+RTAA
DO CHK
KILL RTA,RTQ
DO PULL^RTQ2
DO CHK1
IF '$DATA(RTPAR)
IF $DATA(RTQ)
SET RTPAR=RTQ
+1 QUIT
CHK SET Y=+$ORDER(^RTV(195.9,"ABOR",RTB,RTA,0))
if 'Y
DO SET^RTDPA3
SET RTB=Y
QUIT
+1 ;
CHK1 ;
+1 ; RT*1*34 - this shortcut uses "AC" xref instead of "C"
+2 SET R=0
+3 IF $DATA(^RTV(190.1,"AC",RT,RTTM))
FOR R=0:0
SET R=$ORDER(^RTV(190.1,"AC",RT,RTTM,R))
if 'R
QUIT
IF $DATA(^RTV(190.1,"ABOR",RTB,R))
IF $DATA(^RTV(190.1,R,0))
SET Q0=^(0)
IF $PIECE(Q0,U)=RT
IF $PIECE(Q0,U,4)=RTTM
IF $PIECE(Q0,U,5)=RTB
IF $PIECE(Q0,U,10)=RTPULL
QUIT
+4 IF 'R
DO SET^RTQ
+5 ;F R=0:0 S R=$O(^RTV(190.1,"C",RTTM,R)) Q:'R D INFO I $D(^RTV(190.1,"ABOR",RTB,R)),$D(^RTV(190.1,R,0)) S Q0=^(0) I $P(Q0,"^")=RT,$P(Q0,"^",4)=RTTM,$P(Q0,"^",5)=RTB,$P(Q0,"^",10)=RTPULL Q
+6 ;I 'R D SET^RTQ
+7 QUIT
INFO ;I R#100=0,'$D(ZTSK) W "."
+1 QUIT
Q10 KILL RTLSTM,RADPT,RTLOAD,RTMES1,RTERM,DIC,DIE,DR,DA,DAS,DASH,IF,DIR,COM,J,Z
+1 KILL RTCOUNT,RTHIT,RTLAST,R,RT0,RTAA,RTINST,RTPGM,RTVAR,CR,MOD,RTPHIST
+2 KILL Q0,RTDPT,RT,RTB,RTCL,RTDT,RTE,RTEE,RTERM,RTERM0,RTI,RTLOAD,RTPAR,RTPLTY,RTPN,RTPULL,RTQ,RTQDT,RTRM,RTRM0,RTT,RTTD,RTTM,RTTMM,RTWND,RTXX
DO CLOSE^RTUTL
+3 QUIT
DPTCHK ;returns $t=1 if dhcp activity
+1 SET RTPHIST=1
FILED IF $DATA(^DPT(DFN,0))
IF $PIECE(^(0),"^",16)>RTFLAG(RTI)
QUIT
+1 ;
INPAT IF $DATA(^DPT(DFN,.1))
IF $PIECE(^(.1),"^")]""
QUIT
+1 ;
SC IF $ORDER(^DPT(DFN,"S",RTFLAG(RTI)))
QUIT
+1 ;
SDV ;
+1 ;Standalone encounter exists
NEW RTZERR
IF $$EXAE^SDOE(DFN,RTFLAG(RTI)\1+1,9999999,,"RTZERR")
QUIT
+2 ;
DIS IF $ORDER(^DPT(DFN,"DIS",0))
IF $ORDER(^(0))<(9999999-RTFLAG(RTI))
QUIT
+1 ;
MOV IF $ORDER(^DGPM("APID",DFN,0))
IF $ORDER(^(0))<(9999999-RTFLAG(RTI))
QUIT
+1 ;
+2 SET RTPHIST=0
+3 QUIT
