VistA-IHS-VA_UTILITIES-XB/XBVCH1.m

201 lines
5.4 KiB
Mathematica

XBVCH1 ; IHS/ADC/GTH - CONTINUE VARIABLE CHANGER ; [ 10/29/2002 7:42 AM ]
;;4.0;XB;;Jul 20, 2009;Build 2
;
; Thanks to Paul Wesley, DSD/OIRM, for the original routine.
;
PROCESS ;
S XBL=$L(XBV0),XBOUT=0
S X=0
X ^%ZOSF("RM")
S (XBROU,XBRM)=""
F S XBROU=$O(^XBVROU(XBJ,"R",XBROU)) Q:XBROU="" S XBRM=XBRM_XBROU_","
S XBROU=""
F S XBROU=$O(^XBVROU(XBJ,"R",XBROU)) Q:XBROU="" D Q:$G(XBOUT)
. S X=XBROU
. X ^%ZOSF("TEST")
. E D ^XBCLS W !!,X," NOT FOUND",! KILL DIR S DIR(0)="E" D ^DIR S:(Y=0) XBOUT=1 Q
. S X=XBROU,DIF="^XBVROU(XBJ,""R"","""_XBROU_""",",(XCNP,%N)=0
. X ^%ZOSF("LOAD")
. I ^XBVROU(XBJ,"R",XBROU,1,0)["GENERATED FROM" W !,^(0),! KILL DIR S DIR(0)="E" D ^DIR D ^XBCLS Q
. S XBLN=0,XBEDIT=0
. F S XBLN=$O(^XBVROU(XBJ,"R",XBROU,XBLN)) Q:XBLN="" S XBLIN=^(XBLN,0) D LIN Q:$G(XBOUT)
. I XBEDIT D SAVE
. KILL ^XBVROU(XBJ,"R",XBROU)
.Q
Q
;
DISPROU ;display routine list
S DX=1,DY=22
X XBXY
S XBRD=""
F XBRI=1:1 S XBRD=$P(XBRM,",",XBRI) Q:XBRD="" W:'(XBRI-1#8) ! S XBRC=(10*(XBRI-1#8)) W ?XBRC W:XBRD=XBROU "|" W XBRD W:XBRD=XBROU "|"
Q
;
;--------------------------------------
;
LIN ;PROCESS LINE FROM TOP
S XBLIN0=XBLIN,XBVX=XBV0
Q:XBLIN0'[XBV0
D SCAN0,CHKMK
I '$G(XBMK),$L(XBV0)=1 Q ;skip when single character variable
I '$G(XBMK) KILL XBEDLIN D EDIT,CHKMK Q:'$G(XBMK) Q:$G(XBOUT)
D ACCEPT
Q
;
SCAN0 ;
S XBLINX=XBLIN0,XBVX=XBV0
D SCAN,UPT
Q
;
SCAN1 ;
S XBLINX=XBLIN1,XBVX=XBV1
D SCAN
Q
;
DISP0 ;
S XBVX=XBV0,XBLINX=XBLIN0
D ^XBCLS,DISPLAY
Q
;
DISP1 ;
S XBVX=XBV1,XBLINX=XBLIN1
D DISPLAY
Q
;
SCAN ;
KILL XB,XBT,XBMK
S XBL=$L(XBVX)
F XBI=1:1 S XB(XBI)=$F(XBLINX,XBVX,$G(XB(XBI-1))+1)-XBL Q:XB(XBI)'>0 D
. S XB(XBI,"M")=0,XB(XBI,0)=XB(XBI)
. I XBP[$E(XBLINX,XB(XBI)-1),XBS[$E(XBLINX,XB(XBI)+XBL) S XB(XBI,"M")=1
. S XB("B",XB(XBI))=XBI,XB("E",XB(XBI)+XBL-1)=XBI
. S XB(XBI,"E")=XB(XBI)+XBL-1
.Q
KILL XB(XBI)
CHKMK ;
I XBVX=XBV0 KILL XBMK S XBJM="" F S XBJM=$O(XB(XBJM)) Q:XBJM="" I $G(XB(XBJM,"M")) W *7 S XBMK=1
KILL XBJM
Q
;
EDIT ;
D DISP0
S DX=1,DY=13
X XBXY
R "TAB/T/SPC/CR/R/N/%/^/? :",*X:DTIME
S X=$C(X)
I X="T" D UPT G EDIT
I $A(X)=9 D UPT G EDIT
I X=" " S XB(XBT,"M")=XB(XBT,"M")+1#2 D UPT G EDIT
I X="R" S XBLN=0 KILL XBMK Q
I X="N" S XBLN=999 KILL XBMK Q
; I X="%" D ^XBNEW("%EDIT^XBVCH1:XBJ;XBROU") S XBLN=0 KILL XBMK Q ; IHS/SET/GTH XB*3*9 10/29/2002
I X="%" D EN^XBNEW("%EDIT^XBVCH1","XBJ;XBROU") S XBLN=0 KILL XBMK Q ; IHS/SET/GTH XB*3*9 10/29/2002
I X="^" S XBOUT=1 KILL XBMK Q
KILL XBMK
S XBJM=""
F S XBJM=$O(XB(XBJM)) Q:XBJM="" I $G(XB(XBJM,"M")) W *7 S XBMK=1
KILL XBJM
I $A(X)=13 Q
D ^XBCLS
W !!!
W !?5,"'X' Set changes"
W !?5,"'Tab' or 'T' Move to next marker"
W !?5,"'Space bar' Toggel marker and move to next"
W !?5,"'CR' Skip to next line"
W !?5,"'R' Restart the current Routine"
W !?5,"'%' %E Edit Routine"
W !?5,"'N' Next Routine"
W !?5,"'^' Exit"
KILL DIR
S DIR(0)="E"
D ^DIR
G EDIT
;
DISPLAY ; display line
; XB(XBI,0)=POS XB("B",POS)=XBI XB("E",POS)=XBI XB(XBI,"M")=MARK (0 OR 1)
; XBD(0) =underline-on,XBD(1)=Bold on,XBD(2)=Underline Off,XBD(3)=Bold Off,XBD("RVON")=RVON,XBD("RVOFF")=RVOFF
D:(XBVX=XBV0) ^XBCLS ;displaying current line
D:XBVX=XBV0 DISPROU
S DX=0,DY=0
X XBXY
W ?5,"routine ",XBROU,?35,"line ",XBLN,!!
I XBVX=XBV1 W ! ;displaying new line
W XBD(6)
F XBI=1:1:$L(XBLINX) D
. I '(XBI#80) W !!!
. I $D(XB("B",XBI)) W XBD(XB(XB("B",XBI),"M")*2)
. W $E(XBLINX,XBI)
. I $D(XB("E",XBI)) W XBD(XB(XB("E",XBI),"M")*2+1)
.Q
W XBD(7)
Q:(XBVX=XBV1) ;no tab marker when displaying new line
TAB ;
S DY=+3,DX=XB(XBT,0)#80-1,DY=DY+(XB(XBT,0)\80*3)
S:DY>8 DX=DX+1
TAB1 ;
X XBXY
W XBD(2),"|",XBD(3)
Q
;
UPT ; SET TAB
S XBT=$G(XBT),XBT=$O(XB(XBT))
I XBT'>0 S XBT=0 G UPT
KILL XB("T")
S XB("T",XB(XBT,0))=""
Q
;
BLDLIN1 ;
S XBLIN0=XBLIN,XBSUB=XBV0_":"_XBV1,XBLIN1=""
F XBI=1:1 Q:'$D(XB(XBI)) S XBLIN1=XBLIN1_$E(XBLIN,$G(XB(XBI-1,"E"))+1,XB(XBI,0)-1)_$S(XB(XBI,"M"):XBV1,1:XBV0)
S XBI=XBI-1
S XBLIN1=XBLIN1_$E(XBLIN,XB(XBI,"E")+1,999)
Q
;
ACCEPT ;
D DISP0,BLDLIN1,SCAN1,DISP1
KILL DIR
S DIR(0)="S^Y:ACCEPT;E:EDIT;S:SKIP;N:NEXT ROUTINE;Q:QUIT",DIR("B")="Y"
S X=$P(XBLINX," ",2,999)
F Q:$E(X)'=" " S X=$E(X,2,999)
F Q:$E(X)'="." S X=$E(X,2,999)
D ^DIM
I '$D(X) W *7,!,XBD(2),"FM DIM checker does not like this line !",XBD(3),!,XBD(2),XBLINX,XBD(3),! S DIR("B")="E"
D ^DIR
KILL DIR
I Y="N" S XBLN=999 Q
I Y="S" Q
I Y="E" D SCAN0,EDIT,CHKMK G:$G(XBMK) ACCEPT Q
I Y="Q" S XBOUT=1 Q
I Y'="Y" G ACCEPT
S XBEDIT=1 ; set edit markers
S XBLIN=XBLIN1,^XBVROU(XBJ,"R",XBROU,XBLN,0)=XBLIN ;set new line
Q
;
%EDIT ; USE %E EDITOR
X "ZL @XBROU X ^%E"
KILL ^XBVROU(XBJ,"R",XBROU)
S X=XBROU,DIF="^XBVROU(XBJ,""R"","""_XBROU_""",",(XCNP,%N)=0
X ^%ZOSF("LOAD")
S XBLIN=0
Q
;
SAVE ; SAVE NEW ROUTINE TO DISK
D ^XBCLS
X ^%ZOSF("UCI")
I Y["DEV," W !,"you are in DEV .. NO CHANGES" H 2 Q
I Y["PRD," W !,"you are in PRD .. NO CHANGES" H 2 Q
KILL DIR
S DIR(0)="Y",DIR("A")=XBROU_" has been changed. Save with Changes ?",DIR("B")="Y"
D ^DIR
KILL DIR
I 'Y W !?5,XBROU," NOT CHANGED" H 3 D ^XBCLS Q
W !?5,XBROU,"is being saved with changes",!
S XBSAV1="ZR",XBSAV2="F XBI=1:1 S XBX=$G(^XBVROU(XBJ,""R"",XBROU,XBI,0)) Q:'$L(XBX) ZI XBX",XBSAV3="ZS @XBROU"
X "X XBSAV1,XBSAV2,XBSAV3"
S ^XBVROU("PRT",$J,"VCHG",XBSUB,XBROU)=""
S ^XBVROU("PRT",$J,"RCHG",XBROU,XBSUB)=""
S ^XBVROU(XBJ,"NV",XBV1)=""
W !?5,XBROU,"SAVED WITH CHANGES" H 2
Q
;