RMPR214P ;HDSO/RJH - RMPR*3.0*214 Post-install routine; Aug 9, 2023@16:00
;;3.0;PROSTHETICS;**214**; 30 Oct 98;Build 3
;
;;Reference to $$ICDDX^ICDEX supported by ICR #5747
;;Reference to ^GMR(123,30.1) supported by ICR# 3067
;
Q ; Must be run from a specific tag
;
; ----------------------------------------------------------------------------
; This post-install routine, loosely based on RMPR213P, does the following:
;
; 1. Scan the RECORD OF PROS APPLIANCE/REPAIR file (#660) to look for any
; records with "-1" in the SUSPENSE ICD field (#8.8)
; 2. When found, the corresponding PROVISIONAL DIAGNOSIS field (#8.7), ICD10
; code and CONSULT (#8.9) pointer are retrieved
; 3. Using the CONSULT pointer, the PROVISIONAL DIAGNOSIS CODE (#30.1) is
; from the REQUEST/CONSULTATION file (#123).
; 4. That diagnosis code is then used to call $$ICDDX^ICDEX to return the
; correct ICD10 pointer (IEN) for the code.
; 5. The original record is stored in ^XTMP for potential recovery by
; executing the BACKOUT^RMPR214P logic in programmer mode.
; 6. The corrected ICD10 code is then inserted back into the SUSPENSE ICD
; field in file 660.
;
; Note: The routine is not deleted after install since it is tasked and the
; BACKOUT functionality needs to remain available. A future patch can
; be used to delete the routine, if needed.
;
; ============================================================================
;
EN ; Main entry point
D BMES^XPDUTL("")
D BMES^XPDUTL($$LJ^XLFSTR("The RMPR*3.0*214 Post-Install Routine will scan the RECORD OF PROS ",80))
D MES^XPDUTL($$LJ^XLFSTR("APPLIANCE/REPAIR file (#660) for erroneous ICD fields and if found,",80))
D MES^XPDUTL($$LJ^XLFSTR("attempt to correct them. ",80))
;
N RMPRDUZ,ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTSAVE,ZTQUEUED,ZTREQ,ZTSK
S ZTRTN="START^RMPR214P"
S ZTDESC="RMPR*3.0*214 Post-Install Routine"
S ZTIO="",ZTDTH=$H
S RMPRDUZ=DUZ
S ZTSAVE("RMPRDUZ")=""
D ^%ZTLOAD
;
D BMES^XPDUTL($$LJ^XLFSTR("The RMPR*3.0*214 Post-Install Routine has been tasked.",80))
D MES^XPDUTL($$LJ^XLFSTR("Task Number: "_$G(ZTSK),80))
D MES^XPDUTL($$LJ^XLFSTR("You will receive a MailMan message when it completes.",80))
D BMES^XPDUTL("")
Q
;
START ; Start the correction process
N RMPRSUB,RMPRFROM,RMPRTEXT
;
S ^XTMP("RMPR*3.0*214 POST INSTALL",0)=$$FMADD^XLFDT(DT,90)_"^"_DT_"^RMPR*3.0*214 POST INSTALL"
D RMPR,MAIL
S:$D(ZTQUEUED) ZTREQ="@"
Q
;
RMPR ; Fix records in the RECORD OF PROS APPLIANCE/REPAIR file (#660)
N RMPR,RMPR10,RMSUSICD,RMFND,RMFIXED,RMRXDT,RMCNSLT,RMICD,RMICDIEN,RMNODE
S RMNODE="RMPR*3.0*214 POST INSTALL"
S (RMPR,RMFND,RMFIXED)=0
;
F S RMPR=$O(^RMPR(660,RMPR)) Q:'RMPR D
. Q:'$D(^RMPR(660,RMPR,10))
. S RMPR10=$G(^RMPR(660,RMPR,10))
. S RMSUSICD=$P(RMPR10,"^",8)
. Q:RMSUSICD'="-1"
. ; If we're here, a bad record has been found
. S RMFND=RMFND+1
. S RMCNSLT=$P(RMPR10,"^",9) Q:RMCNSLT=""
. S RMRXDT=$P(RMPR10,"^",2) S:RMRXDT'>0 RMRXDT=DT
. Q:'$$FIND1^DIC(123,,"A",RMCNSLT)
. S RMICD=$$GET1^DIQ(123,RMCNSLT,30.1),RMICD=$P(RMICD,U,1)
. Q:RMICD=""
. S RMICDIEN=$P($$ICDDX^ICDEX(RMICD,RMRXDT),"^")
. Q:RMICDIEN<0
. ; Now save the original and then fix the bad record
. S ^XTMP(RMNODE,0,660,RMPR,10)=RMPR10
. S $P(^RMPR(660,RMPR,10),"^",8)=RMICDIEN
. S RMFIXED=RMFIXED+1
. Q
;
S ^XTMP(RMNODE,1)=" "
S ^XTMP(RMNODE,2)="********** RMPR*3.0*214 Post-Install Routine Summary Report **********"
S ^XTMP(RMNODE,3)=" "
S ^XTMP(RMNODE,4)=" Records in the RECORD OF PROS APPLIANCE/REPAIR file (#660) file"
S ^XTMP(RMNODE,5)=" have been searched for an -1 error code in the SUSPENSE ICD field."
S ^XTMP(RMNODE,6)=" "
S ^XTMP(RMNODE,7)=" Number of erroneous records found: "_RMFND
S ^XTMP(RMNODE,8)=" Number of records corrected: "_RMFIXED
S ^XTMP(RMNODE,9)=" "
S ^XTMP(RMNODE,10)=" The original version of corrected records, if any, are stored for"
S ^XTMP(RMNODE,11)=" 90 days at ^XTMP(""RMPR*3.0*214 POST INSTALL"",0,660,recordID)."
S ^XTMP(RMNODE,12)=" "
S ^XTMP(RMNODE,13)="*************************** End of Report ****************************"
;
Q
;
MAIL ; Send MailMan message to installer and users with the RMPRMANAGER key
S RMPRSUB="RMPR*3.0*214 Post-Install Summary Information"
S RMPRFROM="RMPR*3.0*214 Post-Install"
S RMPRTEXT="^XTMP(""RMPR*3.0*214 POST INSTALL"")"
D MAILMSG(RMPRSUB,RMPRFROM,RMPRTEXT)
Q
;
; ============================================================================
BACKOUT ; Run this from the programmer's prompt if patch backout is required
W #
N DIR,Y
S DIR("A",1)="This action will back out the file modifications that were performed"
S DIR("A",2)="after the install of RMPR*3.0*214."
S DIR("A")="Are you sure you wish to proceed",DIR("B")="NO",DIR(0)="Y"
D ^DIR
Q:Y<1
;
N RMBKNODE,RMPRDUZ,RMPRNF,RMPRNC,RMPRZ,RMPRREC,RMPRTEXT,RMPRMY,RMPRSUB,RMPRMIN
N RMPRMZ,RMPRFROM
;
S RMBKNODE="RMPR*3.0*214 BACKOUT"
S RMPRDUZ=DUZ
S ^XTMP(RMBKNODE,0)=$$FMADD^XLFDT(DT,90)_"^"_DT_"^RMPR*3.0*214 BACKOUT"
;
W !!,"Please wait until the backout completes."
W !,"Working..."
D ICDBACK,MAILBACK
;
K DIR
N DIR
S DIR("A",1)="MailMan message #"_RMPRMZ_" has been sent to you as well as"
S DIR("A",2)="holders of the RMPRMANAGER security key."
S DIR("A")="Press any key to continue"
S DIR(0)="E" D ^DIR
Q
;
ICDBACK ; Restore the previous (erroneous) records back to #660, node 10
S (RMPRZ,RMPRNF,RMPRNC)=0
;
F S RMPRZ=$O(^XTMP("RMPR*3.0*214 POST INSTALL",0,660,RMPRZ)) Q:RMPRZ="" D
. S ^XTMP(RMBKNODE,0,660,RMPRZ,10)=^RMPR(660,RMPRZ,10)
. S ^RMPR(660,RMPRZ,10)=^XTMP("RMPR*3.0*214 POST INSTALL",0,660,RMPRZ,10)
. S RMPRNF=RMPRNF+1,RMPRNC=RMPRNC+1
. Q
;
S ^XTMP(RMBKNODE,1)=" "
S ^XTMP(RMBKNODE,2)="**************** RMPR*3.0*214 Rollback Summary Report ****************"
S ^XTMP(RMBKNODE,3)=" "
S ^XTMP(RMBKNODE,4)=" Backout was run by "_$$GET1^DIQ(200,DUZ,.01)_" on "_$$FMTE^XLFDT(DT)
S ^XTMP(RMBKNODE,5)=" "
S ^XTMP(RMBKNODE,6)=" Number of records found to rollback: "_RMPRNF
S ^XTMP(RMBKNODE,7)=" Number of records backed out: "_RMPRNC
S ^XTMP(RMBKNODE,8)=" "
S ^XTMP(RMBKNODE,9)=" The previously corrected records will be saved for 90 days at"
S ^XTMP(RMBKNODE,10)=" ^XTMP(""RMPR*3.0*214 BACKOUT"",0,660,recordID)."
S ^XTMP(RMBKNODE,11)=" "
S ^XTMP(RMBKNODE,12)=" The text of this message will also be stored for 90 days at"
S ^XTMP(RMBKNODE,13)=" ^XTMP(""RMPR*3.0*214 BACKOUT""."
S ^XTMP(RMBKNODE,14)=" "
S ^XTMP(RMBKNODE,15)="*************************** End of Report ****************************"
Q
;
MAILBACK ; Send MailMan message with backout info to appropriate group
S RMPRSUB="RMPR*3.0*214 Backout Information"
S RMPRFROM="RMPR*3.0*214 BACKOUT"
S RMPRTEXT="^XTMP(""RMPR*3.0*214 BACKOUT"")"
D MAILMSG(RMPRSUB,RMPRFROM,RMPRTEXT)
Q
;
; ----------------------------------------------------------------------------
MAILMSG(MSGSUBJ,MSGFROM,MSGTEXT) ; Build and send a MailMan message
N RMPRREC,RMPRMY,RMPRMIN
I '$D(RMPRDUZ) S RMPRDUZ=DUZ
S RMPRMIN("FROM")=MSGFROM
S RMPRREC=""
F S RMPRREC=$O(^XUSEC("RMPRMANAGER",RMPRREC)) Q:RMPRREC="" S RMPRMY(RMPRREC)=""
S RMPRMY(RMPRDUZ)=""
D SENDMSG^XMXAPI(RMPRDUZ,MSGSUBJ,MSGTEXT,.RMPRMY,.RMPRMIN,.RMPRMZ,"")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR214P 7401 printed Sep 23, 2025@20:08:04 Page 2
RMPR214P ;HDSO/RJH - RMPR*3.0*214 Post-install routine; Aug 9, 2023@16:00
+1 ;;3.0;PROSTHETICS;**214**; 30 Oct 98;Build 3
+2 ;
+3 ;;Reference to $$ICDDX^ICDEX supported by ICR #5747
+4 ;;Reference to ^GMR(123,30.1) supported by ICR# 3067
+5 ;
+6 ; Must be run from a specific tag
QUIT
+7 ;
+8 ; ----------------------------------------------------------------------------
+9 ; This post-install routine, loosely based on RMPR213P, does the following:
+10 ;
+11 ; 1. Scan the RECORD OF PROS APPLIANCE/REPAIR file (#660) to look for any
+12 ; records with "-1" in the SUSPENSE ICD field (#8.8)
+13 ; 2. When found, the corresponding PROVISIONAL DIAGNOSIS field (#8.7), ICD10
+14 ; code and CONSULT (#8.9) pointer are retrieved
+15 ; 3. Using the CONSULT pointer, the PROVISIONAL DIAGNOSIS CODE (#30.1) is
+16 ; from the REQUEST/CONSULTATION file (#123).
+17 ; 4. That diagnosis code is then used to call $$ICDDX^ICDEX to return the
+18 ; correct ICD10 pointer (IEN) for the code.
+19 ; 5. The original record is stored in ^XTMP for potential recovery by
+20 ; executing the BACKOUT^RMPR214P logic in programmer mode.
+21 ; 6. The corrected ICD10 code is then inserted back into the SUSPENSE ICD
+22 ; field in file 660.
+23 ;
+24 ; Note: The routine is not deleted after install since it is tasked and the
+25 ; BACKOUT functionality needs to remain available. A future patch can
+26 ; be used to delete the routine, if needed.
+27 ;
+28 ; ============================================================================
+29 ;
EN ; Main entry point
+1 DO BMES^XPDUTL("")
+2 DO BMES^XPDUTL($$LJ^XLFSTR("The RMPR*3.0*214 Post-Install Routine will scan the RECORD OF PROS ",80))
+3 DO MES^XPDUTL($$LJ^XLFSTR("APPLIANCE/REPAIR file (#660) for erroneous ICD fields and if found,",80))
+4 DO MES^XPDUTL($$LJ^XLFSTR("attempt to correct them. ",80))
+5 ;
+6 NEW RMPRDUZ,ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTSAVE,ZTQUEUED,ZTREQ,ZTSK
+7 SET ZTRTN="START^RMPR214P"
+8 SET ZTDESC="RMPR*3.0*214 Post-Install Routine"
+9 SET ZTIO=""
SET ZTDTH=$HOROLOG
+10 SET RMPRDUZ=DUZ
+11 SET ZTSAVE("RMPRDUZ")=""
+12 DO ^%ZTLOAD
+13 ;
+14 DO BMES^XPDUTL($$LJ^XLFSTR("The RMPR*3.0*214 Post-Install Routine has been tasked.",80))
+15 DO MES^XPDUTL($$LJ^XLFSTR("Task Number: "_$GET(ZTSK),80))
+16 DO MES^XPDUTL($$LJ^XLFSTR("You will receive a MailMan message when it completes.",80))
+17 DO BMES^XPDUTL("")
+18 QUIT
+19 ;
START ; Start the correction process
+1 NEW RMPRSUB,RMPRFROM,RMPRTEXT
+2 ;
+3 SET ^XTMP("RMPR*3.0*214 POST INSTALL",0)=$$FMADD^XLFDT(DT,90)_"^"_DT_"^RMPR*3.0*214 POST INSTALL"
+4 DO RMPR
DO MAIL
+5 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+6 QUIT
+7 ;
RMPR ; Fix records in the RECORD OF PROS APPLIANCE/REPAIR file (#660)
+1 NEW RMPR,RMPR10,RMSUSICD,RMFND,RMFIXED,RMRXDT,RMCNSLT,RMICD,RMICDIEN,RMNODE
+2 SET RMNODE="RMPR*3.0*214 POST INSTALL"
+3 SET (RMPR,RMFND,RMFIXED)=0
+4 ;
+5 FOR
SET RMPR=$ORDER(^RMPR(660,RMPR))
if 'RMPR
QUIT
Begin DoDot:1
+6 if '$DATA(^RMPR(660,RMPR,10))
QUIT
+7 SET RMPR10=$GET(^RMPR(660,RMPR,10))
+8 SET RMSUSICD=$PIECE(RMPR10,"^",8)
+9 if RMSUSICD'="-1"
QUIT
+10 ; If we're here, a bad record has been found
+11 SET RMFND=RMFND+1
+12 SET RMCNSLT=$PIECE(RMPR10,"^",9)
if RMCNSLT=""
QUIT
+13 SET RMRXDT=$PIECE(RMPR10,"^",2)
if RMRXDT'>0
SET RMRXDT=DT
+14 if '$$FIND1^DIC(123,,"A",RMCNSLT)
QUIT
+15 SET RMICD=$$GET1^DIQ(123,RMCNSLT,30.1)
SET RMICD=$PIECE(RMICD,U,1)
+16 if RMICD=""
QUIT
+17 SET RMICDIEN=$PIECE($$ICDDX^ICDEX(RMICD,RMRXDT),"^")
+18 if RMICDIEN<0
QUIT
+19 ; Now save the original and then fix the bad record
+20 SET ^XTMP(RMNODE,0,660,RMPR,10)=RMPR10
+21 SET $PIECE(^RMPR(660,RMPR,10),"^",8)=RMICDIEN
+22 SET RMFIXED=RMFIXED+1
+23 QUIT
End DoDot:1
+24 ;
+25 SET ^XTMP(RMNODE,1)=" "
+26 SET ^XTMP(RMNODE,2)="********** RMPR*3.0*214 Post-Install Routine Summary Report **********"
+27 SET ^XTMP(RMNODE,3)=" "
+28 SET ^XTMP(RMNODE,4)=" Records in the RECORD OF PROS APPLIANCE/REPAIR file (#660) file"
+29 SET ^XTMP(RMNODE,5)=" have been searched for an -1 error code in the SUSPENSE ICD field."
+30 SET ^XTMP(RMNODE,6)=" "
+31 SET ^XTMP(RMNODE,7)=" Number of erroneous records found: "_RMFND
+32 SET ^XTMP(RMNODE,8)=" Number of records corrected: "_RMFIXED
+33 SET ^XTMP(RMNODE,9)=" "
+34 SET ^XTMP(RMNODE,10)=" The original version of corrected records, if any, are stored for"
+35 SET ^XTMP(RMNODE,11)=" 90 days at ^XTMP(""RMPR*3.0*214 POST INSTALL"",0,660,recordID)."
+36 SET ^XTMP(RMNODE,12)=" "
+37 SET ^XTMP(RMNODE,13)="*************************** End of Report ****************************"
+38 ;
+39 QUIT
+40 ;
MAIL ; Send MailMan message to installer and users with the RMPRMANAGER key
+1 SET RMPRSUB="RMPR*3.0*214 Post-Install Summary Information"
+2 SET RMPRFROM="RMPR*3.0*214 Post-Install"
+3 SET RMPRTEXT="^XTMP(""RMPR*3.0*214 POST INSTALL"")"
+4 DO MAILMSG(RMPRSUB,RMPRFROM,RMPRTEXT)
+5 QUIT
+6 ;
+7 ; ============================================================================
BACKOUT ; Run this from the programmer's prompt if patch backout is required
+1 WRITE #
+2 NEW DIR,Y
+3 SET DIR("A",1)="This action will back out the file modifications that were performed"
+4 SET DIR("A",2)="after the install of RMPR*3.0*214."
+5 SET DIR("A")="Are you sure you wish to proceed"
SET DIR("B")="NO"
SET DIR(0)="Y"
+6 DO ^DIR
+7 if Y<1
QUIT
+8 ;
+9 NEW RMBKNODE,RMPRDUZ,RMPRNF,RMPRNC,RMPRZ,RMPRREC,RMPRTEXT,RMPRMY,RMPRSUB,RMPRMIN
+10 NEW RMPRMZ,RMPRFROM
+11 ;
+12 SET RMBKNODE="RMPR*3.0*214 BACKOUT"
+13 SET RMPRDUZ=DUZ
+14 SET ^XTMP(RMBKNODE,0)=$$FMADD^XLFDT(DT,90)_"^"_DT_"^RMPR*3.0*214 BACKOUT"
+15 ;
+16 WRITE !!,"Please wait until the backout completes."
+17 WRITE !,"Working..."
+18 DO ICDBACK
DO MAILBACK
+19 ;
+20 KILL DIR
+21 NEW DIR
+22 SET DIR("A",1)="MailMan message #"_RMPRMZ_" has been sent to you as well as"
+23 SET DIR("A",2)="holders of the RMPRMANAGER security key."
+24 SET DIR("A")="Press any key to continue"
+25 SET DIR(0)="E"
DO ^DIR
+26 QUIT
+27 ;
ICDBACK ; Restore the previous (erroneous) records back to #660, node 10
+1 SET (RMPRZ,RMPRNF,RMPRNC)=0
+2 ;
+3 FOR
SET RMPRZ=$ORDER(^XTMP("RMPR*3.0*214 POST INSTALL",0,660,RMPRZ))
if RMPRZ=""
QUIT
Begin DoDot:1
+4 SET ^XTMP(RMBKNODE,0,660,RMPRZ,10)=^RMPR(660,RMPRZ,10)
+5 SET ^RMPR(660,RMPRZ,10)=^XTMP("RMPR*3.0*214 POST INSTALL",0,660,RMPRZ,10)
+6 SET RMPRNF=RMPRNF+1
SET RMPRNC=RMPRNC+1
+7 QUIT
End DoDot:1
+8 ;
+9 SET ^XTMP(RMBKNODE,1)=" "
+10 SET ^XTMP(RMBKNODE,2)="**************** RMPR*3.0*214 Rollback Summary Report ****************"
+11 SET ^XTMP(RMBKNODE,3)=" "
+12 SET ^XTMP(RMBKNODE,4)=" Backout was run by "_$$GET1^DIQ(200,DUZ,.01)_" on "_$$FMTE^XLFDT(DT)
+13 SET ^XTMP(RMBKNODE,5)=" "
+14 SET ^XTMP(RMBKNODE,6)=" Number of records found to rollback: "_RMPRNF
+15 SET ^XTMP(RMBKNODE,7)=" Number of records backed out: "_RMPRNC
+16 SET ^XTMP(RMBKNODE,8)=" "
+17 SET ^XTMP(RMBKNODE,9)=" The previously corrected records will be saved for 90 days at"
+18 SET ^XTMP(RMBKNODE,10)=" ^XTMP(""RMPR*3.0*214 BACKOUT"",0,660,recordID)."
+19 SET ^XTMP(RMBKNODE,11)=" "
+20 SET ^XTMP(RMBKNODE,12)=" The text of this message will also be stored for 90 days at"
+21 SET ^XTMP(RMBKNODE,13)=" ^XTMP(""RMPR*3.0*214 BACKOUT""."
+22 SET ^XTMP(RMBKNODE,14)=" "
+23 SET ^XTMP(RMBKNODE,15)="*************************** End of Report ****************************"
+24 QUIT
+25 ;
MAILBACK ; Send MailMan message with backout info to appropriate group
+1 SET RMPRSUB="RMPR*3.0*214 Backout Information"
+2 SET RMPRFROM="RMPR*3.0*214 BACKOUT"
+3 SET RMPRTEXT="^XTMP(""RMPR*3.0*214 BACKOUT"")"
+4 DO MAILMSG(RMPRSUB,RMPRFROM,RMPRTEXT)
+5 QUIT
+6 ;
+7 ; ----------------------------------------------------------------------------
MAILMSG(MSGSUBJ,MSGFROM,MSGTEXT) ; Build and send a MailMan message
+1 NEW RMPRREC,RMPRMY,RMPRMIN
+2 IF '$DATA(RMPRDUZ)
SET RMPRDUZ=DUZ
+3 SET RMPRMIN("FROM")=MSGFROM
+4 SET RMPRREC=""
+5 FOR
SET RMPRREC=$ORDER(^XUSEC("RMPRMANAGER",RMPRREC))
if RMPRREC=""
QUIT
SET RMPRMY(RMPRREC)=""
+6 SET RMPRMY(RMPRDUZ)=""
+7 DO SENDMSG^XMXAPI(RMPRDUZ,MSGSUBJ,MSGTEXT,.RMPRMY,.RMPRMIN,.RMPRMZ,"")
+8 QUIT
