XBVCH1 ; IHS/ADC/GTH - CONTINUE VARIABLE CHANGER ; [ 10/29/2002 7:42 AM ]
;;3.0;IHS/VA UTILITIES;**9**;FEB 07, 1997
;
; 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
;
XBVCH1 ; IHS/ADC/GTH - CONTINUE VARIABLE CHANGER ; [ 10/29/2002 7:42 AM ]
+1 ;;3.0;IHS/VA UTILITIES;**9**;FEB 07, 1997
+2 ;
+3 ; Thanks to Paul Wesley, DSD/OIRM, for the original routine.
+4 ;
PROCESS ;
+1 SET XBL=$LENGTH(XBV0)
SET XBOUT=0
+2 SET X=0
+3 XECUTE ^%ZOSF("RM")
+4 SET (XBROU,XBRM)=""
+5 FOR
SET XBROU=$ORDER(^XBVROU(XBJ,"R",XBROU))
IF XBROU=""
QUIT
SET XBRM=XBRM_XBROU_","
+6 SET XBROU=""
+7 FOR
SET XBROU=$ORDER(^XBVROU(XBJ,"R",XBROU))
IF XBROU=""
QUIT
Begin DoDot:1
+8 SET X=XBROU
+9 XECUTE ^%ZOSF("TEST")
+10 IF '$TEST
DO ^XBCLS
WRITE !!,X," NOT FOUND",!
KILL DIR
SET DIR(0)="E"
DO ^DIR
IF (Y=0)
SET XBOUT=1
QUIT
+11 SET X=XBROU
SET DIF="^XBVROU(XBJ,""R"","""_XBROU_""","
SET (XCNP,%N)=0
+12 XECUTE ^%ZOSF("LOAD")
+13 IF ^XBVROU(XBJ,"R",XBROU,1,0)["GENERATED FROM"
WRITE !,^(0),!
KILL DIR
SET DIR(0)="E"
DO ^DIR
DO ^XBCLS
QUIT
+14 SET XBLN=0
SET XBEDIT=0
+15 FOR
SET XBLN=$ORDER(^XBVROU(XBJ,"R",XBROU,XBLN))
IF XBLN=""
QUIT
SET XBLIN=^(XBLN,0)
DO LIN
IF $GET(XBOUT)
QUIT
+16 IF XBEDIT
DO SAVE
+17 KILL ^XBVROU(XBJ,"R",XBROU)
+18 QUIT
End DoDot:1
IF $GET(XBOUT)
QUIT
+19 QUIT
+20 ;
DISPROU ;display routine list
+1 SET DX=1
SET DY=22
+2 XECUTE XBXY
+3 SET XBRD=""
+4 FOR XBRI=1:1
SET XBRD=$PIECE(XBRM,",",XBRI)
IF XBRD=""
QUIT
IF '(XBRI-1#8)
WRITE !
SET XBRC=(10*(XBRI-1#8))
WRITE ?XBRC
IF XBRD=XBROU
WRITE "|"
WRITE XBRD
IF XBRD=XBROU
WRITE "|"
+5 QUIT
+6 ;
+7 ;--------------------------------------
+8 ;
LIN ;PROCESS LINE FROM TOP
+1 SET XBLIN0=XBLIN
SET XBVX=XBV0
+2 IF XBLIN0'[XBV0
QUIT
+3 DO SCAN0
DO CHKMK
+4 ;skip when single character variable
IF '$GET(XBMK)
IF $LENGTH(XBV0)=1
QUIT
+5 IF '$GET(XBMK)
KILL XBEDLIN
DO EDIT
DO CHKMK
IF '$GET(XBMK)
QUIT
IF $GET(XBOUT)
QUIT
+6 DO ACCEPT
+7 QUIT
+8 ;
SCAN0 ;
+1 SET XBLINX=XBLIN0
SET XBVX=XBV0
+2 DO SCAN
DO UPT
+3 QUIT
+4 ;
SCAN1 ;
+1 SET XBLINX=XBLIN1
SET XBVX=XBV1
+2 DO SCAN
+3 QUIT
+4 ;
DISP0 ;
+1 SET XBVX=XBV0
SET XBLINX=XBLIN0
+2 DO ^XBCLS
DO DISPLAY
+3 QUIT
+4 ;
DISP1 ;
+1 SET XBVX=XBV1
SET XBLINX=XBLIN1
+2 DO DISPLAY
+3 QUIT
+4 ;
SCAN ;
+1 KILL XB,XBT,XBMK
+2 SET XBL=$LENGTH(XBVX)
+3 FOR XBI=1:1
SET XB(XBI)=$FIND(XBLINX,XBVX,$GET(XB(XBI-1))+1)-XBL
IF XB(XBI)'>0
QUIT
Begin DoDot:1
+4 SET XB(XBI,"M")=0
SET XB(XBI,0)=XB(XBI)
+5 IF XBP[$EXTRACT(XBLINX,XB(XBI)-1)
IF XBS[$EXTRACT(XBLINX,XB(XBI)+XBL)
SET XB(XBI,"M")=1
+6 SET XB("B",XB(XBI))=XBI
SET XB("E",XB(XBI)+XBL-1)=XBI
+7 SET XB(XBI,"E")=XB(XBI)+XBL-1
+8 QUIT
End DoDot:1
+9 KILL XB(XBI)
CHKMK ;
+1 IF XBVX=XBV0
KILL XBMK
SET XBJM=""
FOR
SET XBJM=$ORDER(XB(XBJM))
IF XBJM=""
QUIT
IF $GET(XB(XBJM,"M"))
WRITE *7
SET XBMK=1
+2 KILL XBJM
+3 QUIT
+4 ;
EDIT ;
+1 DO DISP0
+2 SET DX=1
SET DY=13
+3 XECUTE XBXY
+4 READ "TAB/T/SPC/CR/R/N/%/^/? :",*X:DTIME
+5 SET X=$CHAR(X)
+6 IF X="T"
DO UPT
GOTO EDIT
+7 IF $ASCII(X)=9
DO UPT
GOTO EDIT
+8 IF X=" "
SET XB(XBT,"M")=XB(XBT,"M")+1#2
DO UPT
GOTO EDIT
+9 IF X="R"
SET XBLN=0
KILL XBMK
QUIT
+10 IF X="N"
SET XBLN=999
KILL XBMK
QUIT
+11 ; I X="%" D ^XBNEW("%EDIT^XBVCH1:XBJ;XBROU") S XBLN=0 KILL XBMK Q ; IHS/SET/GTH XB*3*9 10/29/2002
+12 ; IHS/SET/GTH XB*3*9 10/29/2002
IF X="%"
DO EN^XBNEW("%EDIT^XBVCH1","XBJ;XBROU")
SET XBLN=0
KILL XBMK
QUIT
+13 IF X="^"
SET XBOUT=1
KILL XBMK
QUIT
+14 KILL XBMK
+15 SET XBJM=""
+16 FOR
SET XBJM=$ORDER(XB(XBJM))
IF XBJM=""
QUIT
IF $GET(XB(XBJM,"M"))
WRITE *7
SET XBMK=1
+17 KILL XBJM
+18 IF $ASCII(X)=13
QUIT
+19 DO ^XBCLS
+20 WRITE !!!
+21 WRITE !?5,"'X' Set changes"
+22 WRITE !?5,"'Tab' or 'T' Move to next marker"
+23 WRITE !?5,"'Space bar' Toggel marker and move to next"
+24 WRITE !?5,"'CR' Skip to next line"
+25 WRITE !?5,"'R' Restart the current Routine"
+26 WRITE !?5,"'%' %E Edit Routine"
+27 WRITE !?5,"'N' Next Routine"
+28 WRITE !?5,"'^' Exit"
+29 KILL DIR
+30 SET DIR(0)="E"
+31 DO ^DIR
+32 GOTO EDIT
+33 ;
DISPLAY ; display line
+1 ; XB(XBI,0)=POS XB("B",POS)=XBI XB("E",POS)=XBI XB(XBI,"M")=MARK (0 OR 1)
+2 ; XBD(0) =underline-on,XBD(1)=Bold on,XBD(2)=Underline Off,XBD(3)=Bold Off,XBD("RVON")=RVON,XBD("RVOFF")=RVOFF
+3 ;displaying current line
IF (XBVX=XBV0)
DO ^XBCLS
+4 IF XBVX=XBV0
DO DISPROU
+5 SET DX=0
SET DY=0
+6 XECUTE XBXY
+7 WRITE ?5,"routine ",XBROU,?35,"line ",XBLN,!!
+8 ;displaying new line
IF XBVX=XBV1
WRITE !
+9 WRITE XBD(6)
+10 FOR XBI=1:1:$LENGTH(XBLINX)
Begin DoDot:1
+11 IF '(XBI#80)
WRITE !!!
+12 IF $DATA(XB("B",XBI))
WRITE XBD(XB(XB("B",XBI),"M")*2)
+13 WRITE $EXTRACT(XBLINX,XBI)
+14 IF $DATA(XB("E",XBI))
WRITE XBD(XB(XB("E",XBI),"M")*2+1)
+15 QUIT
End DoDot:1
+16 WRITE XBD(7)
+17 ;no tab marker when displaying new line
IF (XBVX=XBV1)
QUIT
TAB ;
+1 SET DY=+3
SET DX=XB(XBT,0)#80-1
SET DY=DY+(XB(XBT,0)\80*3)
+2 IF DY>8
SET DX=DX+1
TAB1 ;
+1 XECUTE XBXY
+2 WRITE XBD(2),"|",XBD(3)
+3 QUIT
+4 ;
UPT ; SET TAB
+1 SET XBT=$GET(XBT)
SET XBT=$ORDER(XB(XBT))
+2 IF XBT'>0
SET XBT=0
GOTO UPT
+3 KILL XB("T")
+4 SET XB("T",XB(XBT,0))=""
+5 QUIT
+6 ;
BLDLIN1 ;
+1 SET XBLIN0=XBLIN
SET XBSUB=XBV0_":"_XBV1
SET XBLIN1=""
+2 FOR XBI=1:1
IF '$DATA(XB(XBI))
QUIT
SET XBLIN1=XBLIN1_$EXTRACT(XBLIN,$GET(XB(XBI-1,"E"))+1,XB(XBI,0)-1)_$SELECT(XB(XBI,"M"):XBV1,1:XBV0)
+3 SET XBI=XBI-1
+4 SET XBLIN1=XBLIN1_$EXTRACT(XBLIN,XB(XBI,"E")+1,999)
+5 QUIT
+6 ;
ACCEPT ;
+1 DO DISP0
DO BLDLIN1
DO SCAN1
DO DISP1
+2 KILL DIR
+3 SET DIR(0)="S^Y:ACCEPT;E:EDIT;S:SKIP;N:NEXT ROUTINE;Q:QUIT"
SET DIR("B")="Y"
+4 SET X=$PIECE(XBLINX," ",2,999)
+5 FOR
IF $EXTRACT(X)'=" "
QUIT
SET X=$EXTRACT(X,2,999)
+6 FOR
IF $EXTRACT(X)'="."
QUIT
SET X=$EXTRACT(X,2,999)
+7 DO ^DIM
+8 IF '$DATA(X)
WRITE *7,!,XBD(2),"FM DIM checker does not like this line !",XBD(3),!,XBD(2),XBLINX,XBD(3),!
SET DIR("B")="E"
+9 DO ^DIR
+10 KILL DIR
+11 IF Y="N"
SET XBLN=999
QUIT
+12 IF Y="S"
QUIT
+13 IF Y="E"
DO SCAN0
DO EDIT
DO CHKMK
IF $GET(XBMK)
GOTO ACCEPT
QUIT
+14 IF Y="Q"
SET XBOUT=1
QUIT
+15 IF Y'="Y"
GOTO ACCEPT
+16 ; set edit markers
SET XBEDIT=1
+17 ;set new line
SET XBLIN=XBLIN1
SET ^XBVROU(XBJ,"R",XBROU,XBLN,0)=XBLIN
+18 QUIT
+19 ;
%EDIT ; USE %E EDITOR
+1 XECUTE "ZL @XBROU X ^%E"
+2 KILL ^XBVROU(XBJ,"R",XBROU)
+3 SET X=XBROU
SET DIF="^XBVROU(XBJ,""R"","""_XBROU_""","
SET (XCNP,%N)=0
+4 XECUTE ^%ZOSF("LOAD")
+5 SET XBLIN=0
+6 QUIT
+7 ;
SAVE ; SAVE NEW ROUTINE TO DISK
+1 DO ^XBCLS
+2 XECUTE ^%ZOSF("UCI")
+3 IF Y["DEV,"
WRITE !,"you are in DEV .. NO CHANGES"
HANG 2
QUIT
+4 IF Y["PRD,"
WRITE !,"you are in PRD .. NO CHANGES"
HANG 2
QUIT
+5 KILL DIR
+6 SET DIR(0)="Y"
SET DIR("A")=XBROU_" has been changed. Save with Changes ?"
SET DIR("B")="Y"
+7 DO ^DIR
+8 KILL DIR
+9 IF 'Y
WRITE !?5,XBROU," NOT CHANGED"
HANG 3
DO ^XBCLS
QUIT
+10 WRITE !?5,XBROU,"is being saved with changes",!
+11 SET XBSAV1="ZR"
SET XBSAV2="F XBI=1:1 S XBX=$G(^XBVROU(XBJ,""R"",XBROU,XBI,0)) Q:'$L(XBX) ZI XBX"
SET XBSAV3="ZS @XBROU"
+12 XECUTE "X XBSAV1,XBSAV2,XBSAV3"
+13 SET ^XBVROU("PRT",$JOB,"VCHG",XBSUB,XBROU)=""
+14 SET ^XBVROU("PRT",$JOB,"RCHG",XBROU,XBSUB)=""
+15 SET ^XBVROU(XBJ,"NV",XBV1)=""
+16 WRITE !?5,XBROU,"SAVED WITH CHANGES"
HANG 2
+17 QUIT
+18 ;
