RMPR124P ;VMP/RB - FIX FIELD LENGTH PROBLEMS FOR FILES #660/664 ;01/13/06
;;3.0;Prosthetics;**124**;06/20/05;Build 17
;;
;1. Post install to correct fields with length error created during
; cut & paste for function key input during GUI process and passed
; to VISTA files 660 and 664 for fields: Brief Description, Remarks,
; Serial #, Manufacturer, Model and Lot #
;
FIX664 ;search and correct length in errors for specified fields in files 664
W @IOF
W !,"** THIS TEMPORARY PROCESS HAS BEEN PUT IN PLACE TO SCRUB (VIA USER **"
W !,"** INTERACTION) ANY FIELDS IN FILE #664 AND FILE#660 THAT MAY HAVE **"
W !,"** A FIELD LENGTH ERROR CAUSED BY THE GUI PROSTHETICS PURCHASING **"
W !,"** MODULE WHICH WAS ALLOWING DATA OUTSIDE THE FIELD DEFINED LENGTH **"
W !,"** LIMITATIONS. **"
F1 S %=1,DTOUT=0 W !!,"WANT TO PROCEED WITH CLEANSING PROCESS" D YN^DICN I '% W !,"REPLY YES (Y) OR NO (N)" G F1
S ANS=$S('(%-1):"Y",1:"N") I ANS="N"!$D(DIRUT)!$D(DUOUT) G EXIT
W !!
EN ;Entry Point.
N DIR,DA,ZTRTN,ZTDESC,RMOPT,ZTSK,ZTQUEUED,ZTIO,POP
S DIR("?")="Please enter 1, 2, or 3."
S DIR("?",1)="Please note: Options 2 & 3 work directly from the temporary"
S DIR("?",2)="file created by length error compile under Option 1 - COMPILE."
S DIR("?",3)=""
S DIR(0)="SO^1:COMPILE LENGTH ERRORS;2:PRINT LENGTH ERROR REPORT;3:FIX LENGTH ERRORS"
S DIR("L",1)="Select one of the following:"
S DIR("L",2)=""
S DIR("L",3)="1 Compile 2 Report 3 Fix Length Errors"
D ^DIR
S RMOPT=Y
Q:RMOPT=""
K DIR,DA Q:$D(DIRUT)
I RMOPT=1 D ASKCMP Q
I RMOPT=2 D PRINT^RMPRFPRT Q
I RMOPT=3 D FIX Q
G EXIT
ASKCMP ;COMPILE ASK
N RMSTART,RMCREATE,RMPURGE,RMEND,RMREM
S Y=$G(^XTMP("RMPRFIX","START COMPILE")) D DD^%DT S RMSTART=Y
S Y=$G(^XTMP("RMPRFIX","END COMPILE")) D DD^%DT S RMEND=Y
I RMEND="RUNNING" D Q
.W !!,"Build started on ",RMSTART," still running!"
.D WAIT
S RMREM=$G(^XTMP("RMPRFIX","RMPR","COUNT"))
I RMEND'="" D
.W !!,"Last Build completed on ",RMEND
.I +RMREM>0 W !!,"This build contains ",+RMREM," nodes to be fixed, ",+$P(RMREM,"^",2)," field length errors",!
.I +RMREM=0 W !!,"There are 0 items to be fixed.",!
S DIR("A")="Do you wish to continue with NEW Build? "
S DIR(0)="Y",DIR("B")="NO"
D ^DIR
K DA,DIR Q:$D(DIRUT)
I Y=0 Q
CMP ;COMPILE
K %DT,Y
K ^XTMP("RMPRFIX")
D CLEAR^VALM1
;D BUILD^RMPR124P Q
S ZTRTN="BUILD^RMPR124P"
S ZTDESC="UTILITY FOR RMPR FIELD LENGTH ERRORS"
S ZTSAVE("RM*")="",ZTSAVE("XM*")="",ZTIO=""
D ^%ZTLOAD
I $D(ZTSK) W !,"Request Queued!"
D WAIT
Q
BUILD D NOW^%DTC S RMSTART=%
S ^XTMP("RMPRFIX","START COMPILE")=RMSTART
S ^XTMP("RMPRFIX","END COMPILE")="RUNNING"
S ^XTMP("RMPRFIX",0)=$$FMADD^XLFDT(RMSTART,90)_"^"_RMSTART
FIX ;FIX BY INTERNAL PTR FOR 660/664
N IEN0,IEN4,R664,IEN42,R40,R42,R43,R660,R6601,R6609,FLD1,FLD2,FLD7,FLD15,FLD152,FLD154,FLD156,FLD19,FLD211,FLD9
N FLD16,FLD21,FLD24,FLD25,FLD91,FLD92,FLD1D,FLD2,DIE,DA,DR,DA1,DA2,DA1A,FILE1,FILE2,END,DATA,LMIN,LMAX,WDS
N DTOUT,DUOUT,DIRUT,DIR,I,J,ANS,TT,IWD,PCN,HSW,WDA,WDB,WDC,HDT,NUM,Y,TFND,TFIX,RMUSER,RMOBN,HIEN,RMPRCT1,RMPRCT2
D:RMOPT=1 BEG^RMPRFFIX D:RMOPT=3 ENT^RMPRFFIX
G EXIT:END=1
EXIT0 W:RMOPT=3 !!,"** REPAIR PROCESS COMPLETE: ",$S(TFND=0:"NO FIELD LENGTH ERRORS FOUND",1:TFIX_" FIELD LENGTH ERRORS CORRECTED")
EXIT I $G(END)=1,RMOPT=3 W !!,"** REPAIR PROCESS TERMINATED BY USER **" I TFIX>0 W " < ",TFIX_" FIELD LENGTH ERRORS CORRECTED"," >"
I $G(RMOPT)=1 D
. D NOW^%DTC S RMEND=%
. S ^XTMP("RMPRFIX","RMPR","COUNT")=RMPRCT1_"^"_RMPRCT2
. S ^XTMP("RMPRFIX","END COMPILE")=RMEND
. D MAIL
Q
MAIL ;Send mail message when build complete.
N XMAIL,XMSUB,XMDUZ,XMTEXT,RMTEXT,Y,XMY,XMMG,XMZ
S Y=$G(RMSTART) D DD^%DT S PXSTART=Y
S Y=$G(RMEND) D DD^%DT S PXEND=Y
S ZTQUEUED=1
S RMTEXT(1)="UTILITY FOR RMPR FIELD LENGTH ERRORS is ready to report & fix."
S RMTEXT(1)="Compile for RMPR field length errors is complete and ready to report & fix."
S RMTEXT(2)="Start time: "_$G(PXSTART)_" End time: "_$G(PXEND)
S XMSUB="RMPR field length error cleanup...Build Completed.."
S XMTEXT="RMTEXT(",XMDUZ=.5,XMY(DUZ)=""
D ^XMD
S ^XTMP("RMPRFIX","RMPR","RMMAIL")=$G(XMZ)_"^"_DUZ_"^"_$G(XMMG)
Q
WAIT ;
;Q:IO'=$G(IO("HOME"))
N DIR,X,Y,DIRUT,DUOUT,DTOUT,DIROUT
W ! S DIR(0)="E" S DIR("A")="Enter RETURN to continue" D ^DIR W !
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR124P 4433 printed Apr 09, 2024@21:34:15 Page 2
RMPR124P ;VMP/RB - FIX FIELD LENGTH PROBLEMS FOR FILES #660/664 ;01/13/06
+1 ;;3.0;Prosthetics;**124**;06/20/05;Build 17
+2 ;;
+3 ;1. Post install to correct fields with length error created during
+4 ; cut & paste for function key input during GUI process and passed
+5 ; to VISTA files 660 and 664 for fields: Brief Description, Remarks,
+6 ; Serial #, Manufacturer, Model and Lot #
+7 ;
FIX664 ;search and correct length in errors for specified fields in files 664
+1 WRITE @IOF
+2 WRITE !,"** THIS TEMPORARY PROCESS HAS BEEN PUT IN PLACE TO SCRUB (VIA USER **"
+3 WRITE !,"** INTERACTION) ANY FIELDS IN FILE #664 AND FILE#660 THAT MAY HAVE **"
+4 WRITE !,"** A FIELD LENGTH ERROR CAUSED BY THE GUI PROSTHETICS PURCHASING **"
+5 WRITE !,"** MODULE WHICH WAS ALLOWING DATA OUTSIDE THE FIELD DEFINED LENGTH **"
+6 WRITE !,"** LIMITATIONS. **"
F1 SET %=1
SET DTOUT=0
WRITE !!,"WANT TO PROCEED WITH CLEANSING PROCESS"
DO YN^DICN
IF '%
WRITE !,"REPLY YES (Y) OR NO (N)"
GOTO F1
+1 SET ANS=$SELECT('(%-1):"Y",1:"N")
IF ANS="N"!$DATA(DIRUT)!$DATA(DUOUT)
GOTO EXIT
+2 WRITE !!
EN ;Entry Point.
+1 NEW DIR,DA,ZTRTN,ZTDESC,RMOPT,ZTSK,ZTQUEUED,ZTIO,POP
+2 SET DIR("?")="Please enter 1, 2, or 3."
+3 SET DIR("?",1)="Please note: Options 2 & 3 work directly from the temporary"
+4 SET DIR("?",2)="file created by length error compile under Option 1 - COMPILE."
+5 SET DIR("?",3)=""
+6 SET DIR(0)="SO^1:COMPILE LENGTH ERRORS;2:PRINT LENGTH ERROR REPORT;3:FIX LENGTH ERRORS"
+7 SET DIR("L",1)="Select one of the following:"
+8 SET DIR("L",2)=""
+9 SET DIR("L",3)="1 Compile 2 Report 3 Fix Length Errors"
+10 DO ^DIR
+11 SET RMOPT=Y
+12 if RMOPT=""
QUIT
+13 KILL DIR,DA
if $DATA(DIRUT)
QUIT
+14 IF RMOPT=1
DO ASKCMP
QUIT
+15 IF RMOPT=2
DO PRINT^RMPRFPRT
QUIT
+16 IF RMOPT=3
DO FIX
QUIT
+17 GOTO EXIT
ASKCMP ;COMPILE ASK
+1 NEW RMSTART,RMCREATE,RMPURGE,RMEND,RMREM
+2 SET Y=$GET(^XTMP("RMPRFIX","START COMPILE"))
DO DD^%DT
SET RMSTART=Y
+3 SET Y=$GET(^XTMP("RMPRFIX","END COMPILE"))
DO DD^%DT
SET RMEND=Y
+4 IF RMEND="RUNNING"
Begin DoDot:1
+5 WRITE !!,"Build started on ",RMSTART," still running!"
+6 DO WAIT
End DoDot:1
QUIT
+7 SET RMREM=$GET(^XTMP("RMPRFIX","RMPR","COUNT"))
+8 IF RMEND'=""
Begin DoDot:1
+9 WRITE !!,"Last Build completed on ",RMEND
+10 IF +RMREM>0
WRITE !!,"This build contains ",+RMREM," nodes to be fixed, ",+$PIECE(RMREM,"^",2)," field length errors",!
+11 IF +RMREM=0
WRITE !!,"There are 0 items to be fixed.",!
End DoDot:1
+12 SET DIR("A")="Do you wish to continue with NEW Build? "
+13 SET DIR(0)="Y"
SET DIR("B")="NO"
+14 DO ^DIR
+15 KILL DA,DIR
if $DATA(DIRUT)
QUIT
+16 IF Y=0
QUIT
CMP ;COMPILE
+1 KILL %DT,Y
+2 KILL ^XTMP("RMPRFIX")
+3 DO CLEAR^VALM1
+4 ;D BUILD^RMPR124P Q
+5 SET ZTRTN="BUILD^RMPR124P"
+6 SET ZTDESC="UTILITY FOR RMPR FIELD LENGTH ERRORS"
+7 SET ZTSAVE("RM*")=""
SET ZTSAVE("XM*")=""
SET ZTIO=""
+8 DO ^%ZTLOAD
+9 IF $DATA(ZTSK)
WRITE !,"Request Queued!"
+10 DO WAIT
+11 QUIT
BUILD DO NOW^%DTC
SET RMSTART=%
+1 SET ^XTMP("RMPRFIX","START COMPILE")=RMSTART
+2 SET ^XTMP("RMPRFIX","END COMPILE")="RUNNING"
+3 SET ^XTMP("RMPRFIX",0)=$$FMADD^XLFDT(RMSTART,90)_"^"_RMSTART
FIX ;FIX BY INTERNAL PTR FOR 660/664
+1 NEW IEN0,IEN4,R664,IEN42,R40,R42,R43,R660,R6601,R6609,FLD1,FLD2,FLD7,FLD15,FLD152,FLD154,FLD156,FLD19,FLD211,FLD9
+2 NEW FLD16,FLD21,FLD24,FLD25,FLD91,FLD92,FLD1D,FLD2,DIE,DA,DR,DA1,DA2,DA1A,FILE1,FILE2,END,DATA,LMIN,LMAX,WDS
+3 NEW DTOUT,DUOUT,DIRUT,DIR,I,J,ANS,TT,IWD,PCN,HSW,WDA,WDB,WDC,HDT,NUM,Y,TFND,TFIX,RMUSER,RMOBN,HIEN,RMPRCT1,RMPRCT2
+4 if RMOPT=1
DO BEG^RMPRFFIX
if RMOPT=3
DO ENT^RMPRFFIX
+5 if END=1
GOTO EXIT
EXIT0 if RMOPT=3
WRITE !!,"** REPAIR PROCESS COMPLETE: ",$SELECT(TFND=0:"NO FIELD LENGTH ERRORS FOUND",1:TFIX_" FIELD LENGTH ERRORS CORRECTED")
EXIT IF $GET(END)=1
IF RMOPT=3
WRITE !!,"** REPAIR PROCESS TERMINATED BY USER **"
IF TFIX>0
WRITE " < ",TFIX_" FIELD LENGTH ERRORS CORRECTED"," >"
+1 IF $GET(RMOPT)=1
Begin DoDot:1
+2 DO NOW^%DTC
SET RMEND=%
+3 SET ^XTMP("RMPRFIX","RMPR","COUNT")=RMPRCT1_"^"_RMPRCT2
+4 SET ^XTMP("RMPRFIX","END COMPILE")=RMEND
+5 DO MAIL
End DoDot:1
+6 QUIT
MAIL ;Send mail message when build complete.
+1 NEW XMAIL,XMSUB,XMDUZ,XMTEXT,RMTEXT,Y,XMY,XMMG,XMZ
+2 SET Y=$GET(RMSTART)
DO DD^%DT
SET PXSTART=Y
+3 SET Y=$GET(RMEND)
DO DD^%DT
SET PXEND=Y
+4 SET ZTQUEUED=1
+5 SET RMTEXT(1)="UTILITY FOR RMPR FIELD LENGTH ERRORS is ready to report & fix."
+6 SET RMTEXT(1)="Compile for RMPR field length errors is complete and ready to report & fix."
+7 SET RMTEXT(2)="Start time: "_$GET(PXSTART)_" End time: "_$GET(PXEND)
+8 SET XMSUB="RMPR field length error cleanup...Build Completed.."
+9 SET XMTEXT="RMTEXT("
SET XMDUZ=.5
SET XMY(DUZ)=""
+10 DO ^XMD
+11 SET ^XTMP("RMPRFIX","RMPR","RMMAIL")=$GET(XMZ)_"^"_DUZ_"^"_$GET(XMMG)
+12 QUIT
WAIT ;
+1 ;Q:IO'=$G(IO("HOME"))
+2 NEW DIR,X,Y,DIRUT,DUOUT,DTOUT,DIROUT
+3 WRITE !
SET DIR(0)="E"
SET DIR("A")="Enter RETURN to continue"
DO ^DIR
WRITE !
+4 QUIT
