SDES2MRTCCLEAN ;ALB/LAB - MRTC IT Clean up Utility ; FEB 23,2026
;;5.3;SCHEDULING;**929**;AUG 13, 1993;Build 9
;;Per VHA Directive 6402, this routine should not be modified
;;
Q
;
CLEANUP ;
N INPID,POP,PIDDATE,DIR,CNT,UPDATE,LEAVE,RUN,REQIEN,PRTIDX,RETN,X,ERROR
S POP=0
D VERIFYRUN(.RUN)
Q:'RUN
D REQUESTPROMPT(.REQIEN,.LEAVE)
Q:+$G(LEAVE)
D MRTCCLEAN(.RETN,REQIEN,.ERROR)
I ($G(ERROR)'="") D
. S UPDATE=0
. D FIN(UPDATE,ERROR)
Q:$G(ERROR)'=""
S PRTIDX=""
F S PRTIDX=$O(RETN(PRTIDX)) Q:PRTIDX="" D
. W !,RETN(PRTIDX)
D PRINTORUPDATE(.UPDATE,.LEAVE)
I UPDATE D
. S PRTIDX=""
. F S PRTIDX=$O(RETN(PRTIDX)) Q:PRTIDX="" D
. . X RETN(PRTIDX)
D FIN(UPDATE,$G(ERROR))
Q
;
VERIFYRUN(Y) ;display what option does and verify user wants to run
N DIRUT,DIR,X1,X2,X
;
; Entry Point for clean-up with user specified dates
;
W !!,"This OPTION will loop through the entered request and will clean update the MRTC"
W !,"parent request and all children request of the parent request."
W !!
S DIR(0)="Y"
S DIR("A")="Are you sure you would like to run the MRTC cleanup tool"
S DIR("?")="Enter 'Y'es or 'N'o."
S DIR("B")="YES"
D ^DIR
Q
;
REQUESTPROMPT(Y,DIRUT) ;prompt for pid to search on
N DIR
K DIR
S DIR(0)="FO"
S DIR("A")="Enter Request IEN"
D ^DIR
Q
;
;
PRINTORUPDATE(Y,DIRUT) ;does user want to print report only or udpate and print
N Y
W !!
S DIR(0)="Y"
S DIR("A")="Would you like to UPDATE the records? Enter 'N'o to print only."
S DIR("?")="Enter 'Y'es to UPDATE and PRINT the records or 'N'o to print records only."
S DIR("B")="NO"
D ^DIR
G:$G(DIRUT) EXIT
S UPDATE=Y
W !!
Q
;
MRTCCLEAN(RETN,REQUESTIEN,ERROR) ;
N REQLIST,APPTDATE,APPTIEN,APPTREQTYPE,B,ORIGCHILDCNT,PARENTIEN
N PATIENTDFN,REQCNT,REQIDX,REQIEN,REQPARENT,REQUESTLIST,STATUS,TOTALREQ,UPDATECNT,CNT
N MRTCARRAY,MRTCARRAY2,RETIDX,DATEDISPOSITION,DISPOSITIONARRAY,DISPOSITION
N DISPOSITIONBY,IDATEDISP,APPTFOUND,DISP,DISPBY,INDEXCNT
;Validate REQUESTIEN
S:($$GET1^DIQ(409.85,REQUESTIEN_",",.01,"I")="") ERROR="Invalid request IEN."
Q:$G(ERROR)'=""
S:($G(REQUESTIEN)="")!($$GET1^DIQ(409.85,REQUESTIEN_",",41,"I")'=1) ERROR="Request null or not an MRTC request."
Q:$G(ERROR)'=""
S PARENTIEN=$$GET1^DIQ(409.85,REQUESTIEN,43.8,"I")
S:PARENTIEN="" PARENTIEN=REQUESTIEN
S MRTCARRAY(PARENTIEN,0)=$$GET1^DIQ(409.85,PARENTIEN,23,"E")
S PATIENTDFN=$$GET1^DIQ(409.85,PARENTIEN,.01,"I")
S REQIEN=PARENTIEN
S ORIGCHILDCNT=0,RETIDX=0
F S REQIEN=$O(^SDEC(409.85,"B",PATIENTDFN,REQIEN)) Q:+REQIEN=0 D
. Q:$$GET1^DIQ(409.85,REQIEN_",",41,"I")'=1
. S REQPARENT=$$GET1^DIQ(409.85,REQIEN,43.8,"I")
. Q:REQPARENT'=PARENTIEN
. S ORIGCHILDCNT=ORIGCHILDCNT+1
. S STATUS=$$GET1^DIQ(409.85,REQIEN,23,"E")
. S DISPOSITION=$$GET1^DIQ(409.85,REQIEN,21,"I")
. S DISPOSITIONBY=$$GET1^DIQ(409.85,REQIEN,20,"I")
. S DATEDISPOSITION=$$GET1^DIQ(409.85,REQIEN,19,"I")
. S:DATEDISPOSITION'="" DISPOSITIONARRAY(DATEDISPOSITION,REQIEN)=U_DISPOSITION_U_DISPOSITIONBY_U_DATEDISPOSITION
. S MRTCARRAY(PARENTIEN,REQIEN)=STATUS_U_$$GET1^DIQ(409.85,REQIEN,21,"E")_U_$$GET1^DIQ(409.85,REQIEN,20,"E")_U_$$GET1^DIQ(409.85,REQIEN,19,"E")
. S MRTCARRAY("STATUS",$$GET1^DIQ(409.85,REQIEN,23,"E"),REQIEN)=""
. I STATUS="OPEN" D
. . S MRTCARRAY("OPEN")=$G(MRTCARRAY("OPEN"))+1
. . S REQLIST(REQIEN)=""
S TOTALREQ=$G(MRTCARRAY("OPEN"))
S APPTDATE=$$GET1^DIQ(409.85,PARENTIEN,1,"I")
S APPTFOUND=0
F S APPTDATE=$O(^SDEC(409.84,"APTDT",PATIENTDFN,APPTDATE)) Q:+APPTDATE=0 D
. S APPTIEN=0
. F S APPTIEN=$O(^SDEC(409.84,"APTDT",PATIENTDFN,APPTDATE,APPTIEN)) Q:+APPTIEN=0 D
. . S APPTREQTYPE=$$GET1^DIQ(409.84,APPTIEN,.22,"I")
. . Q:$P(APPTREQTYPE,";",2)'="SDEC(409.85,"
. . S REQIEN=$P(APPTREQTYPE,";",1)
. . Q:'$D(MRTCARRAY(PARENTIEN,REQIEN))
. . Q:$$GET1^DIQ(409.84,APPTIEN,.101,"I")'=""
. . Q:$$GET1^DIQ(409.84,APPTIEN,.12,"I")'=""
. . S APPTFOUND=1
. . S $P(MRTCARRAY(PARENTIEN,REQIEN),U,5)=APPTIEN
. . S IDATEDISP=$$GET1^DIQ(409.85,REQIEN,19,"I")
. . S:(IDATEDISP'="") $P(DISPOSITIONARRAY(IDATEDISP,REQIEN),U,1)=APPTIEN
. . S MRTCARRAY(PARENTIEN,"CLOSED",REQIEN)=APPTIEN
. . S REQLIST(REQIEN)=""
. . S TOTALREQ=$G(TOTALREQ)+1
I ($G(MRTCARRAY(PARENTIEN,0))="OPEN")&'(+$G(MRTCARRAY("OPEN"))) D
. ;determine dispostion information and close parent
. ;DISPOSITIONARRAY(3210810,250642)="286399^3^520881776^3210810"
. N DATEDISP,REQIEN
. S DATEDISP="",REQIEN=""
. S DATEDISP=$O(DISPOSITIONARRAY(DATEDISP),-1)
. S:DATEDISP'="" REQIEN=$O(DISPOSITIONARRAY(DATEDISP,REQIEN),-1)
. I $G(REQIEN)'="" D
. . S:APPTFOUND DISP=$O(^SDEC(409.853,"B","MRTC PARENT CLOSED",""))
. . S:'APPTFOUND DISP=$P(DISPOSITIONARRAY(DATEDISP,REQIEN),U,2)
. . S DISPBY=$P(DISPOSITIONARRAY(DATEDISP,REQIEN),U,3)
. . S RETN(RETIDX)="S $P(^SDEC(409.85,"_PARENTIEN_",0),U,17)="_""""_"C"_""""
. . S RETIDX=RETIDX+1
. . S RETN(RETIDX)="S $P(^SDEC(409.85,"_PARENTIEN_","_""""_"DIS"_""""_"),U,1)="_DATEDISP
. . S RETIDX=RETIDX+1
. . S RETN(RETIDX)="S $P(^SDEC(409.85,"_PARENTIEN_","_""""_"DIS"_""""_"),U,2)="_DISPBY
. . S RETIDX=RETIDX+1
. . S RETN(RETIDX)="S $P(^SDEC(409.85,"_PARENTIEN_","_""""_"DIS"_""""_"),U,3)="_DISP
. . S RETIDX=RETIDX+1
Q:'(+$G(TOTALREQ))
S CNT=0,UPDATECNT=0,REQIEN=0
F S REQIEN=$O(MRTCARRAY(PARENTIEN,REQIEN)) Q:+REQIEN=0 D
. S STATUS=$P(MRTCARRAY(PARENTIEN,REQIEN),U,1)
. S CNT=CNT+1
. I STATUS="OPEN" D
. . S MRTCARRAY2(PARENTIEN,2,CNT,0)=REQIEN
. . S MRTCARRAY2(PARENTIEN,2,"B",REQIEN,CNT)=""
. . S MRTCARRAY2(PARENTIEN,5,CNT,0)=$$GET1^DIQ(409.85,REQIEN,22,"I")
. . S MRTCARRAY2(PARENTIEN,5,"B",$$GET1^DIQ(409.85,REQIEN,22,"I"),CNT)=""
. . S UPDATECNT=UPDATECNT+1
. . S REQUESTLIST(UPDATECNT)=REQIEN
. . S INDEXCNT=CNT
. I STATUS="CLOSED" D
. . S APPTIEN=$P($G(MRTCARRAY(PARENTIEN,"CLOSED",REQIEN)),"^",1)
. . Q:APPTIEN=""
. . S UPDATECNT=UPDATECNT+1
. . S REQUESTLIST(UPDATECNT)=REQIEN
. . S MRTCARRAY2(PARENTIEN,2,CNT,0)=REQIEN_U_APPTIEN
. . S MRTCARRAY2(PARENTIEN,2,"B",REQIEN,CNT)=""
. . S MRTCARRAY2(PARENTIEN,5,CNT,0)=$$GET1^DIQ(409.85,REQIEN,22,"I")
. . S MRTCARRAY2(PARENTIEN,5,"B",$$GET1^DIQ(409.85,REQIEN,22,"I"),CNT)=""
. . S INDEXCNT=CNT
S MRTCARRAY2(PARENTIEN,2,0)=""""_"^409.852P^"_INDEXCNT_U_UPDATECNT_""""
S MRTCARRAY2(PARENTIEN,5,0)=""""_"^409.851D^"_INDEXCNT_U_UPDATECNT_""""
S RETIDX=RETIDX+1
S RETN(RETIDX)="K ^SDEC(409.85,"_PARENTIEN_",2)"
S RETIDX=RETIDX+1
S RETN(RETIDX)="K ^SDEC(409.85,"_PARENTIEN_",5)"
S RETIDX=RETIDX+1
S RETN(RETIDX)="S ^SDEC(409.85,"_PARENTIEN_",2,0)="_MRTCARRAY2(PARENTIEN,2,0)
S RETIDX=RETIDX+1
S REQIDX=0,B="B"
F S REQIDX=$O(MRTCARRAY2(PARENTIEN,2,REQIDX)) Q:+REQIDX=0 D
. S RETN(RETIDX)="S ^SDEC(409.85,"_PARENTIEN_",2,"_REQIDX_",0)="_""""_MRTCARRAY2(PARENTIEN,2,REQIDX,0)_""""
. S RETIDX=RETIDX+1
;
S REQIDX=0
F S REQIDX=$O(MRTCARRAY2(PARENTIEN,2,REQIDX)) Q:+REQIDX=0 D
. S REQIEN=$P(MRTCARRAY2(PARENTIEN,2,REQIDX,0),U,1)
. S RETN(RETIDX)="S ^SDEC(409.85,"_PARENTIEN_",2,"_""""_B_""""_","_REQIEN_","_REQIDX_")="""_""""
. S RETIDX=RETIDX+1
;
S RETN(RETIDX)="S ^SDEC(409.85,"_PARENTIEN_",5,0)="_MRTCARRAY2(PARENTIEN,5,0)
S RETIDX=RETIDX+1
S REQIDX=0
F S REQIDX=$O(MRTCARRAY2(PARENTIEN,5,REQIDX)) Q:+REQIDX=0 D
. S RETN(RETIDX)="S ^SDEC(409.85,"_PARENTIEN_",5,"_REQIDX_",0)="_""""_MRTCARRAY2(PARENTIEN,5,REQIDX,0)_""""
. S RETIDX=RETIDX+1
;
S REQIDX=0
F S REQIDX=$O(MRTCARRAY2(PARENTIEN,5,REQIDX)) Q:+REQIDX=0 D
. S REQIEN=$P(MRTCARRAY2(PARENTIEN,5,REQIDX,0),U,1)
. S RETN(RETIDX)="S ^SDEC(409.85,"_PARENTIEN_",5,"_""""_B_""""_","_REQIEN_","_REQIDX_")="""_""""
. S RETIDX=RETIDX+1
;
S RETN(RETIDX)="S $P(^SDEC(409.85,"_PARENTIEN_",3),U,3)="_UPDATECNT
S RETIDX=RETIDX+1
I $$GET1^DIQ(409.85,PARENTIEN,43.1,"I")'="" D
. S RETN(RETIDX)="S $P(^SDEC(409.85,"_PARENTIEN_",3),U,6)="_""""_""""
. S RETIDX=RETIDX+1
I ($G(MRTCARRAY(PARENTIEN,0))="CLOSED")&$G(MRTCARRAY("OPEN")) D
. ;open parent
. S RETN(RETIDX)="S $P(^SDEC(409.85,"_PARENTIEN_",0),U,17)="_""""_"O"_""""
. S RETIDX=RETIDX+1
. S RETN(RETIDX)="S $P(^SDEC(409.85,"_PARENTIEN_","_""""_"DIS"_""""_"),U,1)="_""""_""""
. S RETIDX=RETIDX+1
. S RETN(RETIDX)="S $P(^SDEC(409.85,"_PARENTIEN_","_""""_"DIS"_""""_"),U,2)="_""""_""""
. S RETIDX=RETIDX+1
. S RETN(RETIDX)="S $P(^SDEC(409.85,"_PARENTIEN_","_""""_"DIS"_""""_"),U,3)="_""""_""""
. S RETIDX=RETIDX+1
S REQCNT=0
F S REQCNT=$O(REQUESTLIST(REQCNT)) Q:+REQCNT=0 D
. S RETN(RETIDX)="S $P(^SDEC(409.85,"_REQUESTLIST(REQCNT)_",3),U,3)="_UPDATECNT
. S RETIDX=RETIDX+1
. S RETN(RETIDX)="S $P(^SDEC(409.85,"_REQUESTLIST(REQCNT)_",3),U,6)="_REQCNT
. S RETIDX=RETIDX+1
Q
;
;
EXIT ;exit without running
S POP=1
W !,"Nothing done."
Q
;
FIN(UDPATE,ERROR) ;Show final results
;
I $G(ERROR)'="" D
. W !,ERROR
Q:$G(ERROR)'=""
I UPDATE W !!,"Clean-up is complete."
I 'UPDATE W !!,"Report finished."
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDES2MRTCCLEAN 8992 printed Apr 22, 2026@14:52:06 Page 2
SDES2MRTCCLEAN ;ALB/LAB - MRTC IT Clean up Utility ; FEB 23,2026
+1 ;;5.3;SCHEDULING;**929**;AUG 13, 1993;Build 9
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;;
+4 QUIT
+5 ;
CLEANUP ;
+1 NEW INPID,POP,PIDDATE,DIR,CNT,UPDATE,LEAVE,RUN,REQIEN,PRTIDX,RETN,X,ERROR
+2 SET POP=0
+3 DO VERIFYRUN(.RUN)
+4 if 'RUN
QUIT
+5 DO REQUESTPROMPT(.REQIEN,.LEAVE)
+6 if +$GET(LEAVE)
QUIT
+7 DO MRTCCLEAN(.RETN,REQIEN,.ERROR)
+8 IF ($GET(ERROR)'="")
Begin DoDot:1
+9 SET UPDATE=0
+10 DO FIN(UPDATE,ERROR)
End DoDot:1
+11 if $GET(ERROR)'=""
QUIT
+12 SET PRTIDX=""
+13 FOR
SET PRTIDX=$ORDER(RETN(PRTIDX))
if PRTIDX=""
QUIT
Begin DoDot:1
+14 WRITE !,RETN(PRTIDX)
End DoDot:1
+15 DO PRINTORUPDATE(.UPDATE,.LEAVE)
+16 IF UPDATE
Begin DoDot:1
+17 SET PRTIDX=""
+18 FOR
SET PRTIDX=$ORDER(RETN(PRTIDX))
if PRTIDX=""
QUIT
Begin DoDot:2
+19 XECUTE RETN(PRTIDX)
End DoDot:2
End DoDot:1
+20 DO FIN(UPDATE,$GET(ERROR))
+21 QUIT
+22 ;
VERIFYRUN(Y) ;display what option does and verify user wants to run
+1 NEW DIRUT,DIR,X1,X2,X
+2 ;
+3 ; Entry Point for clean-up with user specified dates
+4 ;
+5 WRITE !!,"This OPTION will loop through the entered request and will clean update the MRTC"
+6 WRITE !,"parent request and all children request of the parent request."
+7 WRITE !!
+8 SET DIR(0)="Y"
+9 SET DIR("A")="Are you sure you would like to run the MRTC cleanup tool"
+10 SET DIR("?")="Enter 'Y'es or 'N'o."
+11 SET DIR("B")="YES"
+12 DO ^DIR
+13 QUIT
+14 ;
REQUESTPROMPT(Y,DIRUT) ;prompt for pid to search on
+1 NEW DIR
+2 KILL DIR
+3 SET DIR(0)="FO"
+4 SET DIR("A")="Enter Request IEN"
+5 DO ^DIR
+6 QUIT
+7 ;
+8 ;
PRINTORUPDATE(Y,DIRUT) ;does user want to print report only or udpate and print
+1 NEW Y
+2 WRITE !!
+3 SET DIR(0)="Y"
+4 SET DIR("A")="Would you like to UPDATE the records? Enter 'N'o to print only."
+5 SET DIR("?")="Enter 'Y'es to UPDATE and PRINT the records or 'N'o to print records only."
+6 SET DIR("B")="NO"
+7 DO ^DIR
+8 if $GET(DIRUT)
GOTO EXIT
+9 SET UPDATE=Y
+10 WRITE !!
+11 QUIT
+12 ;
MRTCCLEAN(RETN,REQUESTIEN,ERROR) ;
+1 NEW REQLIST,APPTDATE,APPTIEN,APPTREQTYPE,B,ORIGCHILDCNT,PARENTIEN
+2 NEW PATIENTDFN,REQCNT,REQIDX,REQIEN,REQPARENT,REQUESTLIST,STATUS,TOTALREQ,UPDATECNT,CNT
+3 NEW MRTCARRAY,MRTCARRAY2,RETIDX,DATEDISPOSITION,DISPOSITIONARRAY,DISPOSITION
+4 NEW DISPOSITIONBY,IDATEDISP,APPTFOUND,DISP,DISPBY,INDEXCNT
+5 ;Validate REQUESTIEN
+6 if ($$GET1^DIQ(409.85,REQUESTIEN_",",.01,"I")="")
SET ERROR="Invalid request IEN."
+7 if $GET(ERROR)'=""
QUIT
+8 if ($GET(REQUESTIEN)="")!($$GET1^DIQ(409.85,REQUESTIEN_",",41,"I")'=1)
SET ERROR="Request null or not an MRTC request."
+9 if $GET(ERROR)'=""
QUIT
+10 SET PARENTIEN=$$GET1^DIQ(409.85,REQUESTIEN,43.8,"I")
+11 if PARENTIEN=""
SET PARENTIEN=REQUESTIEN
+12 SET MRTCARRAY(PARENTIEN,0)=$$GET1^DIQ(409.85,PARENTIEN,23,"E")
+13 SET PATIENTDFN=$$GET1^DIQ(409.85,PARENTIEN,.01,"I")
+14 SET REQIEN=PARENTIEN
+15 SET ORIGCHILDCNT=0
SET RETIDX=0
+16 FOR
SET REQIEN=$ORDER(^SDEC(409.85,"B",PATIENTDFN,REQIEN))
if +REQIEN=0
QUIT
Begin DoDot:1
+17 if $$GET1^DIQ(409.85,REQIEN_",",41,"I")'=1
QUIT
+18 SET REQPARENT=$$GET1^DIQ(409.85,REQIEN,43.8,"I")
+19 if REQPARENT'=PARENTIEN
QUIT
+20 SET ORIGCHILDCNT=ORIGCHILDCNT+1
+21 SET STATUS=$$GET1^DIQ(409.85,REQIEN,23,"E")
+22 SET DISPOSITION=$$GET1^DIQ(409.85,REQIEN,21,"I")
+23 SET DISPOSITIONBY=$$GET1^DIQ(409.85,REQIEN,20,"I")
+24 SET DATEDISPOSITION=$$GET1^DIQ(409.85,REQIEN,19,"I")
+25 if DATEDISPOSITION'=""
SET DISPOSITIONARRAY(DATEDISPOSITION,REQIEN)=U_DISPOSITION_U_DISPOSITIONBY_U_DATEDISPOSITION
+26 SET MRTCARRAY(PARENTIEN,REQIEN)=STATUS_U_$$GET1^DIQ(409.85,REQIEN,21,"E")_U_$$GET1^DIQ(409.85,REQIEN,20,"E")_U_$$GET1^DIQ(409.85,REQIEN,19,"E")
+27 SET MRTCARRAY("STATUS",$$GET1^DIQ(409.85,REQIEN,23,"E"),REQIEN)=""
+28 IF STATUS="OPEN"
Begin DoDot:2
+29 SET MRTCARRAY("OPEN")=$GET(MRTCARRAY("OPEN"))+1
+30 SET REQLIST(REQIEN)=""
End DoDot:2
End DoDot:1
+31 SET TOTALREQ=$GET(MRTCARRAY("OPEN"))
+32 SET APPTDATE=$$GET1^DIQ(409.85,PARENTIEN,1,"I")
+33 SET APPTFOUND=0
+34 FOR
SET APPTDATE=$ORDER(^SDEC(409.84,"APTDT",PATIENTDFN,APPTDATE))
if +APPTDATE=0
QUIT
Begin DoDot:1
+35 SET APPTIEN=0
+36 FOR
SET APPTIEN=$ORDER(^SDEC(409.84,"APTDT",PATIENTDFN,APPTDATE,APPTIEN))
if +APPTIEN=0
QUIT
Begin DoDot:2
+37 SET APPTREQTYPE=$$GET1^DIQ(409.84,APPTIEN,.22,"I")
+38 if $PIECE(APPTREQTYPE,";",2)'="SDEC(409.85,"
QUIT
+39 SET REQIEN=$PIECE(APPTREQTYPE,";",1)
+40 if '$DATA(MRTCARRAY(PARENTIEN,REQIEN))
QUIT
+41 if $$GET1^DIQ(409.84,APPTIEN,.101,"I")'=""
QUIT
+42 if $$GET1^DIQ(409.84,APPTIEN,.12,"I")'=""
QUIT
+43 SET APPTFOUND=1
+44 SET $PIECE(MRTCARRAY(PARENTIEN,REQIEN),U,5)=APPTIEN
+45 SET IDATEDISP=$$GET1^DIQ(409.85,REQIEN,19,"I")
+46 if (IDATEDISP'="")
SET $PIECE(DISPOSITIONARRAY(IDATEDISP,REQIEN),U,1)=APPTIEN
+47 SET MRTCARRAY(PARENTIEN,"CLOSED",REQIEN)=APPTIEN
+48 SET REQLIST(REQIEN)=""
+49 SET TOTALREQ=$GET(TOTALREQ)+1
End DoDot:2
End DoDot:1
+50 IF ($GET(MRTCARRAY(PARENTIEN,0))="OPEN")&'(+$GET(MRTCARRAY("OPEN")))
Begin DoDot:1
+51 ;determine dispostion information and close parent
+52 ;DISPOSITIONARRAY(3210810,250642)="286399^3^520881776^3210810"
+53 NEW DATEDISP,REQIEN
+54 SET DATEDISP=""
SET REQIEN=""
+55 SET DATEDISP=$ORDER(DISPOSITIONARRAY(DATEDISP),-1)
+56 if DATEDISP'=""
SET REQIEN=$ORDER(DISPOSITIONARRAY(DATEDISP,REQIEN),-1)
+57 IF $GET(REQIEN)'=""
Begin DoDot:2
+58 if APPTFOUND
SET DISP=$ORDER(^SDEC(409.853,"B","MRTC PARENT CLOSED",""))
+59 if 'APPTFOUND
SET DISP=$PIECE(DISPOSITIONARRAY(DATEDISP,REQIEN),U,2)
+60 SET DISPBY=$PIECE(DISPOSITIONARRAY(DATEDISP,REQIEN),U,3)
+61 SET RETN(RETIDX)="S $P(^SDEC(409.85,"_PARENTIEN_",0),U,17)="_""""_"C"_""""
+62 SET RETIDX=RETIDX+1
+63 SET RETN(RETIDX)="S $P(^SDEC(409.85,"_PARENTIEN_","_""""_"DIS"_""""_"),U,1)="_DATEDISP
+64 SET RETIDX=RETIDX+1
+65 SET RETN(RETIDX)="S $P(^SDEC(409.85,"_PARENTIEN_","_""""_"DIS"_""""_"),U,2)="_DISPBY
+66 SET RETIDX=RETIDX+1
+67 SET RETN(RETIDX)="S $P(^SDEC(409.85,"_PARENTIEN_","_""""_"DIS"_""""_"),U,3)="_DISP
+68 SET RETIDX=RETIDX+1
End DoDot:2
End DoDot:1
+69 if '(+$GET(TOTALREQ))
QUIT
+70 SET CNT=0
SET UPDATECNT=0
SET REQIEN=0
+71 FOR
SET REQIEN=$ORDER(MRTCARRAY(PARENTIEN,REQIEN))
if +REQIEN=0
QUIT
Begin DoDot:1
+72 SET STATUS=$PIECE(MRTCARRAY(PARENTIEN,REQIEN),U,1)
+73 SET CNT=CNT+1
+74 IF STATUS="OPEN"
Begin DoDot:2
+75 SET MRTCARRAY2(PARENTIEN,2,CNT,0)=REQIEN
+76 SET MRTCARRAY2(PARENTIEN,2,"B",REQIEN,CNT)=""
+77 SET MRTCARRAY2(PARENTIEN,5,CNT,0)=$$GET1^DIQ(409.85,REQIEN,22,"I")
+78 SET MRTCARRAY2(PARENTIEN,5,"B",$$GET1^DIQ(409.85,REQIEN,22,"I"),CNT)=""
+79 SET UPDATECNT=UPDATECNT+1
+80 SET REQUESTLIST(UPDATECNT)=REQIEN
+81 SET INDEXCNT=CNT
End DoDot:2
+82 IF STATUS="CLOSED"
Begin DoDot:2
+83 SET APPTIEN=$PIECE($GET(MRTCARRAY(PARENTIEN,"CLOSED",REQIEN)),"^",1)
+84 if APPTIEN=""
QUIT
+85 SET UPDATECNT=UPDATECNT+1
+86 SET REQUESTLIST(UPDATECNT)=REQIEN
+87 SET MRTCARRAY2(PARENTIEN,2,CNT,0)=REQIEN_U_APPTIEN
+88 SET MRTCARRAY2(PARENTIEN,2,"B",REQIEN,CNT)=""
+89 SET MRTCARRAY2(PARENTIEN,5,CNT,0)=$$GET1^DIQ(409.85,REQIEN,22,"I")
+90 SET MRTCARRAY2(PARENTIEN,5,"B",$$GET1^DIQ(409.85,REQIEN,22,"I"),CNT)=""
+91 SET INDEXCNT=CNT
End DoDot:2
End DoDot:1
+92 SET MRTCARRAY2(PARENTIEN,2,0)=""""_"^409.852P^"_INDEXCNT_U_UPDATECNT_""""
+93 SET MRTCARRAY2(PARENTIEN,5,0)=""""_"^409.851D^"_INDEXCNT_U_UPDATECNT_""""
+94 SET RETIDX=RETIDX+1
+95 SET RETN(RETIDX)="K ^SDEC(409.85,"_PARENTIEN_",2)"
+96 SET RETIDX=RETIDX+1
+97 SET RETN(RETIDX)="K ^SDEC(409.85,"_PARENTIEN_",5)"
+98 SET RETIDX=RETIDX+1
+99 SET RETN(RETIDX)="S ^SDEC(409.85,"_PARENTIEN_",2,0)="_MRTCARRAY2(PARENTIEN,2,0)
+100 SET RETIDX=RETIDX+1
+101 SET REQIDX=0
SET B="B"
+102 FOR
SET REQIDX=$ORDER(MRTCARRAY2(PARENTIEN,2,REQIDX))
if +REQIDX=0
QUIT
Begin DoDot:1
+103 SET RETN(RETIDX)="S ^SDEC(409.85,"_PARENTIEN_",2,"_REQIDX_",0)="_""""_MRTCARRAY2(PARENTIEN,2,REQIDX,0)_""""
+104 SET RETIDX=RETIDX+1
End DoDot:1
+105 ;
+106 SET REQIDX=0
+107 FOR
SET REQIDX=$ORDER(MRTCARRAY2(PARENTIEN,2,REQIDX))
if +REQIDX=0
QUIT
Begin DoDot:1
+108 SET REQIEN=$PIECE(MRTCARRAY2(PARENTIEN,2,REQIDX,0),U,1)
+109 SET RETN(RETIDX)="S ^SDEC(409.85,"_PARENTIEN_",2,"_""""_B_""""_","_REQIEN_","_REQIDX_")="""_""""
+110 SET RETIDX=RETIDX+1
End DoDot:1
+111 ;
+112 SET RETN(RETIDX)="S ^SDEC(409.85,"_PARENTIEN_",5,0)="_MRTCARRAY2(PARENTIEN,5,0)
+113 SET RETIDX=RETIDX+1
+114 SET REQIDX=0
+115 FOR
SET REQIDX=$ORDER(MRTCARRAY2(PARENTIEN,5,REQIDX))
if +REQIDX=0
QUIT
Begin DoDot:1
+116 SET RETN(RETIDX)="S ^SDEC(409.85,"_PARENTIEN_",5,"_REQIDX_",0)="_""""_MRTCARRAY2(PARENTIEN,5,REQIDX,0)_""""
+117 SET RETIDX=RETIDX+1
End DoDot:1
+118 ;
+119 SET REQIDX=0
+120 FOR
SET REQIDX=$ORDER(MRTCARRAY2(PARENTIEN,5,REQIDX))
if +REQIDX=0
QUIT
Begin DoDot:1
+121 SET REQIEN=$PIECE(MRTCARRAY2(PARENTIEN,5,REQIDX,0),U,1)
+122 SET RETN(RETIDX)="S ^SDEC(409.85,"_PARENTIEN_",5,"_""""_B_""""_","_REQIEN_","_REQIDX_")="""_""""
+123 SET RETIDX=RETIDX+1
End DoDot:1
+124 ;
+125 SET RETN(RETIDX)="S $P(^SDEC(409.85,"_PARENTIEN_",3),U,3)="_UPDATECNT
+126 SET RETIDX=RETIDX+1
+127 IF $$GET1^DIQ(409.85,PARENTIEN,43.1,"I")'=""
Begin DoDot:1
+128 SET RETN(RETIDX)="S $P(^SDEC(409.85,"_PARENTIEN_",3),U,6)="_""""_""""
+129 SET RETIDX=RETIDX+1
End DoDot:1
+130 IF ($GET(MRTCARRAY(PARENTIEN,0))="CLOSED")&$GET(MRTCARRAY("OPEN"))
Begin DoDot:1
+131 ;open parent
+132 SET RETN(RETIDX)="S $P(^SDEC(409.85,"_PARENTIEN_",0),U,17)="_""""_"O"_""""
+133 SET RETIDX=RETIDX+1
+134 SET RETN(RETIDX)="S $P(^SDEC(409.85,"_PARENTIEN_","_""""_"DIS"_""""_"),U,1)="_""""_""""
+135 SET RETIDX=RETIDX+1
+136 SET RETN(RETIDX)="S $P(^SDEC(409.85,"_PARENTIEN_","_""""_"DIS"_""""_"),U,2)="_""""_""""
+137 SET RETIDX=RETIDX+1
+138 SET RETN(RETIDX)="S $P(^SDEC(409.85,"_PARENTIEN_","_""""_"DIS"_""""_"),U,3)="_""""_""""
+139 SET RETIDX=RETIDX+1
End DoDot:1
+140 SET REQCNT=0
+141 FOR
SET REQCNT=$ORDER(REQUESTLIST(REQCNT))
if +REQCNT=0
QUIT
Begin DoDot:1
+142 SET RETN(RETIDX)="S $P(^SDEC(409.85,"_REQUESTLIST(REQCNT)_",3),U,3)="_UPDATECNT
+143 SET RETIDX=RETIDX+1
+144 SET RETN(RETIDX)="S $P(^SDEC(409.85,"_REQUESTLIST(REQCNT)_",3),U,6)="_REQCNT
+145 SET RETIDX=RETIDX+1
End DoDot:1
+146 QUIT
+147 ;
+148 ;
EXIT ;exit without running
+1 SET POP=1
+2 WRITE !,"Nothing done."
+3 QUIT
+4 ;
FIN(UDPATE,ERROR) ;Show final results
+1 ;
+2 IF $GET(ERROR)'=""
Begin DoDot:1
+3 WRITE !,ERROR
End DoDot:1
+4 if $GET(ERROR)'=""
QUIT
+5 IF UPDATE
WRITE !!,"Clean-up is complete."
+6 IF 'UPDATE
WRITE !!,"Report finished."
+7 QUIT
+8 ;
