source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR124P.m@ 1005

Last change on this file since 1005 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.2 KB
Line 
1RMPR124P ;VMP/RB - FIX FIELD LENGTH PROBLEMS FOR FILES #660/664 ;01/13/06
2 ;;3.0;Prosthetics;**124**;06/20/05;Build 17
3 ;;
4 ;1. Post install to correct fields with length error created during
5 ; cut & paste for function key input during GUI process and passed
6 ; to VISTA files 660 and 664 for fields: Brief Description, Remarks,
7 ; Serial #, Manufacturer, Model and Lot #
8 ;
9FIX664 ;search and correct length in errors for specified fields in files 664
10 W @IOF
11 W !,"** THIS TEMPORARY PROCESS HAS BEEN PUT IN PLACE TO SCRUB (VIA USER **"
12 W !,"** INTERACTION) ANY FIELDS IN FILE #664 AND FILE#660 THAT MAY HAVE **"
13 W !,"** A FIELD LENGTH ERROR CAUSED BY THE GUI PROSTHETICS PURCHASING **"
14 W !,"** MODULE WHICH WAS ALLOWING DATA OUTSIDE THE FIELD DEFINED LENGTH **"
15 W !,"** LIMITATIONS. **"
16F1 S %=1,DTOUT=0 W !!,"WANT TO PROCEED WITH CLEANSING PROCESS" D YN^DICN I '% W !,"REPLY YES (Y) OR NO (N)" G F1
17 S ANS=$S('(%-1):"Y",1:"N") I ANS="N"!$D(DIRUT)!$D(DUOUT) G EXIT
18 W !!
19EN ;Entry Point.
20 N DIR,DA,ZTRTN,ZTDESC,RMOPT,ZTSK,ZTQUEUED,ZTIO,POP
21 S DIR("?")="Please enter 1, 2, or 3."
22 S DIR("?",1)="Please note: Options 2 & 3 work directly from the temporary"
23 S DIR("?",2)="file created by length error compile under Option 1 - COMPILE."
24 S DIR("?",3)=""
25 S DIR(0)="SO^1:COMPILE LENGTH ERRORS;2:PRINT LENGTH ERROR REPORT;3:FIX LENGTH ERRORS"
26 S DIR("L",1)="Select one of the following:"
27 S DIR("L",2)=""
28 S DIR("L",3)="1 Compile 2 Report 3 Fix Length Errors"
29 D ^DIR
30 S RMOPT=Y
31 Q:RMOPT=""
32 K DIR,DA Q:$D(DIRUT)
33 I RMOPT=1 D ASKCMP Q
34 I RMOPT=2 D PRINT^RMPRFPRT Q
35 I RMOPT=3 D FIX Q
36 G EXIT
37ASKCMP ;COMPILE ASK
38 N RMSTART,RMCREATE,RMPURGE,RMEND,RMREM
39 S Y=$G(^XTMP("RMPRFIX","START COMPILE")) D DD^%DT S RMSTART=Y
40 S Y=$G(^XTMP("RMPRFIX","END COMPILE")) D DD^%DT S RMEND=Y
41 I RMEND="RUNNING" D Q
42 .W !!,"Build started on ",RMSTART," still running!"
43 .D WAIT
44 S RMREM=$G(^XTMP("RMPRFIX","RMPR","COUNT"))
45 I RMEND'="" D
46 .W !!,"Last Build completed on ",RMEND
47 .I +RMREM>0 W !!,"This build contains ",+RMREM," nodes to be fixed, ",+$P(RMREM,"^",2)," field length errors",!
48 .I +RMREM=0 W !!,"There are 0 items to be fixed.",!
49 S DIR("A")="Do you wish to continue with NEW Build? "
50 S DIR(0)="Y",DIR("B")="NO"
51 D ^DIR
52 K DA,DIR Q:$D(DIRUT)
53 I Y=0 Q
54CMP ;COMPILE
55 K %DT,Y
56 K ^XTMP("RMPRFIX")
57 D CLEAR^VALM1
58 ;D BUILD^RMPR124P Q
59 S ZTRTN="BUILD^RMPR124P"
60 S ZTDESC="UTILITY FOR RMPR FIELD LENGTH ERRORS"
61 S ZTSAVE("RM*")="",ZTSAVE("XM*")="",ZTIO=""
62 D ^%ZTLOAD
63 I $D(ZTSK) W !,"Request Queued!"
64 D WAIT
65 Q
66BUILD D NOW^%DTC S RMSTART=%
67 S ^XTMP("RMPRFIX","START COMPILE")=RMSTART
68 S ^XTMP("RMPRFIX","END COMPILE")="RUNNING"
69 S ^XTMP("RMPRFIX",0)=$$FMADD^XLFDT(RMSTART,90)_"^"_RMSTART
70FIX ;FIX BY INTERNAL PTR FOR 660/664
71 N IEN0,IEN4,R664,IEN42,R40,R42,R43,R660,R6601,R6609,FLD1,FLD2,FLD7,FLD15,FLD152,FLD154,FLD156,FLD19,FLD211,FLD9
72 N FLD16,FLD21,FLD24,FLD25,FLD91,FLD92,FLD1D,FLD2,DIE,DA,DR,DA1,DA2,DA1A,FILE1,FILE2,END,DATA,LMIN,LMAX,WDS
73 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
74 D:RMOPT=1 BEG^RMPRFFIX D:RMOPT=3 ENT^RMPRFFIX
75 G EXIT:END=1
76EXIT0 W:RMOPT=3 !!,"** REPAIR PROCESS COMPLETE: ",$S(TFND=0:"NO FIELD LENGTH ERRORS FOUND",1:TFIX_" FIELD LENGTH ERRORS CORRECTED")
77EXIT I $G(END)=1,RMOPT=3 W !!,"** REPAIR PROCESS TERMINATED BY USER **" I TFIX>0 W " < ",TFIX_" FIELD LENGTH ERRORS CORRECTED"," >"
78 I $G(RMOPT)=1 D
79 . D NOW^%DTC S RMEND=%
80 . S ^XTMP("RMPRFIX","RMPR","COUNT")=RMPRCT1_"^"_RMPRCT2
81 . S ^XTMP("RMPRFIX","END COMPILE")=RMEND
82 . D MAIL
83 Q
84MAIL ;Send mail message when build complete.
85 N XMAIL,XMSUB,XMDUZ,XMTEXT,RMTEXT,Y,XMY,XMMG,XMZ
86 S Y=$G(RMSTART) D DD^%DT S PXSTART=Y
87 S Y=$G(RMEND) D DD^%DT S PXEND=Y
88 S ZTQUEUED=1
89 S RMTEXT(1)="UTILITY FOR RMPR FIELD LENGTH ERRORS is ready to report & fix."
90 S RMTEXT(1)="Compile for RMPR field length errors is complete and ready to report & fix."
91 S RMTEXT(2)="Start time: "_$G(PXSTART)_" End time: "_$G(PXEND)
92 S XMSUB="RMPR field length error cleanup...Build Completed.."
93 S XMTEXT="RMTEXT(",XMDUZ=.5,XMY(DUZ)=""
94 D ^XMD
95 S ^XTMP("RMPRFIX","RMPR","RMMAIL")=$G(XMZ)_"^"_DUZ_"^"_$G(XMMG)
96 Q
97WAIT ;
98 ;Q:IO'=$G(IO("HOME"))
99 N DIR,X,Y,DIRUT,DUOUT,DTOUT,DIROUT
100 W ! S DIR(0)="E" S DIR("A")="Enter RETURN to continue" D ^DIR W !
101 Q
Note: See TracBrowser for help on using the repository browser.