XBFORM ; IHS/ADC/GTH - BUILD ARRAY FROM WP FORMAT ; [ 07/08/1999 3:53 PM ]
;;3.0;IHS/VA UTILITIES;**7**;JULY 9, 1999
;
; Please refer to routine XBFORM0 for documentation.
;
Q
;
EDIT(XBFORM,XBWPDIC,XBWPFLD) ;EP Edit a Form
EDIT2 ;
KILL ^TMP($J,"XBFORM",XBFORM)
S XBLLINE=0,XBFMT=1
I $D(XBLMMRK) S XBLMMARK=XBLMMRK
I '$D(XBLMMARK) S XBLMMARK=$$DIR^XBDIR("Y","MARKERS ","N")
S XBLMMRK=XBLMMARK
D EDITWP,WPGET,BUILD,ZBUILD
;** add RV markers
I '$D(XBLMMARK) S XBLMMARK=$$DIR^XBDIR("Y","MARKERS ","N")
I $D(DIRUT) D EXIT KILL XBLLINE Q
MARK ;
I $G(XBLMMARK) F XBRVL=5:5 Q:'$D(XBZ(XBRVL)) S:'(XBRVL#10) $E(XBZ(XBRVL,0),80)=$E(XBRVL)
KILL XBRVL
D ARRAY^XBLM("XBZ(",XBFORM),CLEAR^VALM1
I $$DIR^XBDIR("S^R:Re-Edit;Q:Quit")="R" KILL XBZ G EDIT2
D EXIT
KILL XBLLINE
Q
;
GEN(XBFORM,XBWPDIC,XBWPFLD,XBREF,XBFMT,XBLAST) ;EP ** generate array
NEW XBLLINE
S XBLLINE=$G(XBLAST)
I $D(^TMP($J,"XBFORM",XBFORM)) D ZBUILD,REFBUILD,EXIT Q XBLLINE
D WPGET,BUILD,ZBUILD,REFBUILD,EXIT
Q XBLLINE
;
EDITWP ;** edit WP array
KILL DIE,DIC,DA,DR
S DIC=XBWPDIC,DR=XBWPFLD,DIC(0)="AEQMLZ"
I $L($G(XBFORM))>0 S X=XBFORM,DIC(0)="XL"
D ^DIC
I Y'>0 S XBQUIT=1 Q
S DIE=$$DIC^XBDIQ1(XBWPDIC),DA=+Y,DR=XBWPFLD
D ^DIE
Q
;
WPGET ;** get WP array
KILL XBWP,XBL,XBOUT,XBVAR,XBWWP,DIC,DR,DIE,DA
S X=XBFORM,DIC=XBWPDIC,DR=XBWPFLD,DIC(0)="X"
D ^DIC
I Y'>0 S XBWP(1)=XBFORM_" NOT FOUND",XBQUIT=1
S DA=+Y
D ENP^XBDIQ1(XBWPDIC,DA,XBWPFLD,"XBWWP(")
S %X="XBWWP("_XBWPFLD_",",%Y="XBWP("
D %XY^%RCR
KILL XBWWP
Q
;
BUILD ;** scan WP array to build XBL
S XBWPL="",XBLINE=0
Q:$D(^TMP($J,"XBFORM",XBFORM))
F S XBWPL=$O(XBWP(XBWPL)) Q:XBWPL'>0 D LINE
Q
;
LINE ;** process one line of the WP array
S Z=XBWP(XBWPL),XBLINE=XBLINE+1
F I=1:1:$L(Z) S A=$E(Z,I) D Q:$G(XBQUIT)
. I I=1,A="#" D MAP S I=$L(Z),XBLINE=XBLINE-1,XBQUIT=1 Q
. I I=1,A="*" D OUT S I=$L(Z),XBLINE=XBLINE-1,XBQUIT=1 Q
. I I=1,A=";" S I=$L(Z),XBLINE=XBLINE-1,XBQUIT=1 Q
. I A'=" ",A'="|" D TEXT Q
. I A="|" D VAR Q
.Q
KILL XBQUIT
Q
;
ZBUILD ;** build Z array from XBL
KILL Z
I '$G(XBFMT) F XBL=1:1 D Q:('$O(^TMP($J,"XBFORM",XBFORM,XBL)))
. I '$D(^TMP($J,"XBFORM",XBFORM,XBL)),$O(^TMP($J,"XBFORM",XBFORM,XBL)) S XBZ(XBL+XBLLINE)=" " Q
. D FILL
.Q
I $G(XBFMT)=1 F XBL=1:1 D Q:('$O(^TMP($J,"XBFORM",XBFORM,XBL)))
. I '$D(^TMP($J,"XBFORM",XBFORM,XBL)),$O(^TMP($J,"XBFORM",XBFORM,XBL)) S XBZ(XBL+XBLLINE,0)=" " Q
. D FILL
.Q
Q
;
REFBUILD ; %RCR BACK TO CALL
S %Y=XBREF,%X="XBZ("
D %XY^%RCR
S XBLLINE=XBLLINE+XBL
Q
;
FILL ;** fill one line
S XBCOL=0,T=""
F S XBCOL=$O(^TMP($J,"XBFORM",XBFORM,XBL,XBCOL)) Q:XBCOL'>0 D
. S X=^TMP($J,"XBFORM",XBFORM,XBL,XBCOL)
. S XBCOLX=XBCOL
. I XBCOL#1 S XBCOLX=XBCOL\1,X="S X="_X X X
. S XBXL=$L(X)
. Q:X=""
. S T=$$SETSTR^VALM1(X,T,XBCOLX,XBXL)
.Q
I T="" S XBLLINE=$G(XBLLINE)-1 Q
S:'$G(XBFMT) XBZ(XBL+XBLLINE)=T
S:($G(XBFMT)=1) XBZ(XBL+XBLLINE,0)=T
Q
;
TEXT ;**
NEW W
S XBCOL=I
F W=I:1:$L(Z) S A=$E(Z,W) Q:A="|"
I W'=$L(Z) S W=W-1
S XBT=$E(Z,I,W),^TMP($J,"XBFORM",XBFORM,XBLINE,XBCOL)=XBT,I=W
Q
;
VAR ;** add .5 to column count to indicate a variable vs text
S XBCOL=I
F W=I+1:1:$L(Z) S A=$E(Z,W) I A="|" Q
S XBT=$E(Z,I+1,W-1)
I XBT="" S XBT="""|"""
S ^TMP($J,"XBFORM",XBFORM,XBLINE,XBCOL+.5)=XBT,I=W
I XBT'["@" D Q
. Q:'$D(XBOUT(XBT))
. I $E(XBOUT(XBT))=";" S XBOUT(XBT)=$$FMSUB(XBOUT(XBT))
. S O=XBOUT(XBT),XBT=$$SUB^XBFORM1(XBT,O)
. S ^TMP($J,"XBFORM",XBFORM,XBLINE,XBCOL+.5)=XBT
.Q
S XBV=$P(XBT,"@"),XBV=XBVAR(XBV),XBS=$P(XBT,"@",2)
I $L(XBS) S XBS="("_XBS_")"
S ^TMP($J,"XBFORM",XBFORM,XBLINE,XBCOL+.5)=XBV_XBS
I $D(XBOUT(XBT)) D
. I $E(XBOUT(XBT))=";" S XBOUT(XBT)=$$FMSUB(XBOUT(XBT))
. S O=XBOUT(XBT),XBT=XBV_XBS,XBT=$$SUB^XBFORM1(XBT,O)
. S ^TMP($J,"XBFORM",XBFORM,XBLINE,XBCOL+.5)=XBT
.Q
Q
;
MAP ;** map shorthand for variables
;#xx1=yyy1|xx2=yyy2|
S Z=$E(Z,2,999)
I Z'["|" S XBVSUB=$P(Z,"="),XBVAL=$P(Z,"=",2),XBVAR(XBVSUB)=XBVAL Q
F I=1:1 S P=$P(Z,"|",I) Q:P="" S XBVSUB=$P(P,"="),XBVAL=$P(P,"=",2),XBVAR(XBVSUB)=XBVAL
Q
;
OUT ;** output transform of data field
;*field:mumps output transform f(x)|
S Z=$E(Z,2,999)
I Z'["|" S XBVSUB=$P(Z,":"),XBVAL=$P(Z,":",2,99),XBOUT(XBVSUB)=XBVAL Q
F I=1:1 S P=$P(Z,"|",I) Q:P="" S XBVSUB=$P(P,":"),XBVAL=$P(P,":",2,99),XBOUT(XBVSUB)=XBVAL
Q
;
TABS ;
S XBF="|....^...."
W #
F I=0:1:7 W ?I*10,I*10
F L=1:1:66 W !?1,L,?3,"..^...." F X=1:1:7 W XBF
Q
;
EXIT ;
KILL XBZ,XBFMT,XBCOL,XBCOLX,XBF,XBL,XBLINE,XBLN,XBLOAD,XBOUT,XBQUIT,XBROU,XBS,XBT,XBTAG,XBTAGE,XBV,XBVAL,XBVAR,XBVSUB,XBWP,XBWPDA,XBWPDIC,XBWPFLD,XBWPL,XBWPNODE,XBWPSUB,XBWWP,XBX,XBXL,XBRVL,XBLWP,XBLMMRK
KILL XBLIN,XBLIN0,XBLIN1,XBLINX
Q
;
MDY(X) ;external date to mm/dd/yy x :: var or ~"NOW"~ or ~"TODAY"~
S %DT="TS"
D ^%DT
;begin Y2K fix block
;S X=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)
S X=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_($E(Y,1,3)+1700) ;Y2000
;end Y2K fix block
Q X
;
WP(X) ;build wp entry X #:: WP(FLD,n)=TEXTn
NEW I,W
S XBLWP=$G(XBLLINE),W=$P(X,")")
F I=0:1 S X=$Q(@X) Q:X="" Q:(W'=$P(X,",")) D
. S T=@X,XBLLINE=XBLWP+I
. S:'$G(XBFMT) XBZ(XBL+XBLLINE)=T
. S:($G(XBFMT)=1) XBZ(XBL+XBLLINE,0)=T
.Q
Q ""
;
FL(X) ; FL fill lines until line X
NEW I,W
S XBLWP=$G(XBLLINE)
Q:((XBLLINE+XBL)'<X) ""
F XBLLINE=XBLLINE:1:X-XBL D
. S T=" "
. S:'$G(XBFMT) XBZ(XBL+XBLLINE)=T
. S:($G(XBFMT)=1) XBZ(XBL+XBLLINE,0)=T
.Q
Q ""
;
FMSUB(X) ;process popular ;D8 ;L20 ;R20
NEW BARC,BARP
S BARC=$E(X,2),BARP=$E(X,3,999)
I BARC="D" S X="$J(X,"_BARP_",2)" Q X
I BARC="L" S X="$E(X,1,"_BARP_")" Q X
I BARC="R" S X="$J(X,"_BARP_")" Q X
S X="X"
Q X
;
XBFORM ; IHS/ADC/GTH - BUILD ARRAY FROM WP FORMAT ; [ 07/08/1999 3:53 PM ]
+1 ;;3.0;IHS/VA UTILITIES;**7**;JULY 9, 1999
+2 ;
+3 ; Please refer to routine XBFORM0 for documentation.
+4 ;
+5 QUIT
+6 ;
EDIT(XBFORM,XBWPDIC,XBWPFLD) ;EP Edit a Form
EDIT2 ;
+1 KILL ^TMP($JOB,"XBFORM",XBFORM)
+2 SET XBLLINE=0
SET XBFMT=1
+3 IF $DATA(XBLMMRK)
SET XBLMMARK=XBLMMRK
+4 IF '$DATA(XBLMMARK)
SET XBLMMARK=$$DIR^XBDIR("Y","MARKERS ","N")
+5 SET XBLMMRK=XBLMMARK
+6 DO EDITWP
DO WPGET
DO BUILD
DO ZBUILD
+7 ;** add RV markers
+8 IF '$DATA(XBLMMARK)
SET XBLMMARK=$$DIR^XBDIR("Y","MARKERS ","N")
+9 IF $DATA(DIRUT)
DO EXIT
KILL XBLLINE
QUIT
MARK ;
+1 IF $GET(XBLMMARK)
FOR XBRVL=5:5
IF '$DATA(XBZ(XBRVL))
QUIT
IF '(XBRVL#10)
SET $EXTRACT(XBZ(XBRVL,0),80)=$EXTRACT(XBRVL)
+2 KILL XBRVL
+3 DO ARRAY^XBLM("XBZ(",XBFORM)
DO CLEAR^VALM1
+4 IF $$DIR^XBDIR("S^R:Re-Edit;Q:Quit")="R"
KILL XBZ
GOTO EDIT2
+5 DO EXIT
+6 KILL XBLLINE
+7 QUIT
+8 ;
GEN(XBFORM,XBWPDIC,XBWPFLD,XBREF,XBFMT,XBLAST) ;EP ** generate array
+1 NEW XBLLINE
+2 SET XBLLINE=$GET(XBLAST)
+3 IF $DATA(^TMP($JOB,"XBFORM",XBFORM))
DO ZBUILD
DO REFBUILD
DO EXIT
QUIT XBLLINE
+4 DO WPGET
DO BUILD
DO ZBUILD
DO REFBUILD
DO EXIT
+5 QUIT XBLLINE
+6 ;
EDITWP ;** edit WP array
+1 KILL DIE,DIC,DA,DR
+2 SET DIC=XBWPDIC
SET DR=XBWPFLD
SET DIC(0)="AEQMLZ"
+3 IF $LENGTH($GET(XBFORM))>0
SET X=XBFORM
SET DIC(0)="XL"
+4 DO ^DIC
+5 IF Y'>0
SET XBQUIT=1
QUIT
+6 SET DIE=$$DIC^XBDIQ1(XBWPDIC)
SET DA=+Y
SET DR=XBWPFLD
+7 DO ^DIE
+8 QUIT
+9 ;
WPGET ;** get WP array
+1 KILL XBWP,XBL,XBOUT,XBVAR,XBWWP,DIC,DR,DIE,DA
+2 SET X=XBFORM
SET DIC=XBWPDIC
SET DR=XBWPFLD
SET DIC(0)="X"
+3 DO ^DIC
+4 IF Y'>0
SET XBWP(1)=XBFORM_" NOT FOUND"
SET XBQUIT=1
+5 SET DA=+Y
+6 DO ENP^XBDIQ1(XBWPDIC,DA,XBWPFLD,"XBWWP(")
+7 SET %X="XBWWP("_XBWPFLD_","
SET %Y="XBWP("
+8 DO %XY^%RCR
+9 KILL XBWWP
+10 QUIT
+11 ;
BUILD ;** scan WP array to build XBL
+1 SET XBWPL=""
SET XBLINE=0
+2 IF $DATA(^TMP($JOB,"XBFORM",XBFORM))
QUIT
+3 FOR
SET XBWPL=$ORDER(XBWP(XBWPL))
IF XBWPL'>0
QUIT
DO LINE
+4 QUIT
+5 ;
LINE ;** process one line of the WP array
+1 SET Z=XBWP(XBWPL)
SET XBLINE=XBLINE+1
+2 FOR I=1:1:$LENGTH(Z)
SET A=$EXTRACT(Z,I)
Begin DoDot:1
+3 IF I=1
IF A="#"
DO MAP
SET I=$LENGTH(Z)
SET XBLINE=XBLINE-1
SET XBQUIT=1
QUIT
+4 IF I=1
IF A="*"
DO OUT
SET I=$LENGTH(Z)
SET XBLINE=XBLINE-1
SET XBQUIT=1
QUIT
+5 IF I=1
IF A=";"
SET I=$LENGTH(Z)
SET XBLINE=XBLINE-1
SET XBQUIT=1
QUIT
+6 IF A'=" "
IF A'="|"
DO TEXT
QUIT
+7 IF A="|"
DO VAR
QUIT
+8 QUIT
End DoDot:1
IF $GET(XBQUIT)
QUIT
+9 KILL XBQUIT
+10 QUIT
+11 ;
ZBUILD ;** build Z array from XBL
+1 KILL Z
+2 IF '$GET(XBFMT)
FOR XBL=1:1
Begin DoDot:1
+3 IF '$DATA(^TMP($JOB,"XBFORM",XBFORM,XBL))
IF $ORDER(^TMP($JOB,"XBFORM",XBFORM,XBL))
SET XBZ(XBL+XBLLINE)=" "
QUIT
+4 DO FILL
+5 QUIT
End DoDot:1
IF ('$ORDER(^TMP($JOB,"XBFORM",XBFORM,XBL)))
QUIT
+6 IF $GET(XBFMT)=1
FOR XBL=1:1
Begin DoDot:1
+7 IF '$DATA(^TMP($JOB,"XBFORM",XBFORM,XBL))
IF $ORDER(^TMP($JOB,"XBFORM",XBFORM,XBL))
SET XBZ(XBL+XBLLINE,0)=" "
QUIT
+8 DO FILL
+9 QUIT
End DoDot:1
IF ('$ORDER(^TMP($JOB,"XBFORM",XBFORM,XBL)))
QUIT
+10 QUIT
+11 ;
REFBUILD ; %RCR BACK TO CALL
+1 SET %Y=XBREF
SET %X="XBZ("
+2 DO %XY^%RCR
+3 SET XBLLINE=XBLLINE+XBL
+4 QUIT
+5 ;
FILL ;** fill one line
+1 SET XBCOL=0
SET T=""
+2 FOR
SET XBCOL=$ORDER(^TMP($JOB,"XBFORM",XBFORM,XBL,XBCOL))
IF XBCOL'>0
QUIT
Begin DoDot:1
+3 SET X=^TMP($JOB,"XBFORM",XBFORM,XBL,XBCOL)
+4 SET XBCOLX=XBCOL
+5 IF XBCOL#1
SET XBCOLX=XBCOL\1
SET X="S X="_X
XECUTE X
+6 SET XBXL=$LENGTH(X)
+7 IF X=""
QUIT
+8 SET T=$$SETSTR^VALM1(X,T,XBCOLX,XBXL)
+9 QUIT
End DoDot:1
+10 IF T=""
SET XBLLINE=$GET(XBLLINE)-1
QUIT
+11 IF '$GET(XBFMT)
SET XBZ(XBL+XBLLINE)=T
+12 IF ($GET(XBFMT)=1)
SET XBZ(XBL+XBLLINE,0)=T
+13 QUIT
+14 ;
TEXT ;**
+1 NEW W
+2 SET XBCOL=I
+3 FOR W=I:1:$LENGTH(Z)
SET A=$EXTRACT(Z,W)
IF A="|"
QUIT
+4 IF W'=$LENGTH(Z)
SET W=W-1
+5 SET XBT=$EXTRACT(Z,I,W)
SET ^TMP($JOB,"XBFORM",XBFORM,XBLINE,XBCOL)=XBT
SET I=W
+6 QUIT
+7 ;
VAR ;** add .5 to column count to indicate a variable vs text
+1 SET XBCOL=I
+2 FOR W=I+1:1:$LENGTH(Z)
SET A=$EXTRACT(Z,W)
IF A="|"
QUIT
+3 SET XBT=$EXTRACT(Z,I+1,W-1)
+4 IF XBT=""
SET XBT="""|"""
+5 SET ^TMP($JOB,"XBFORM",XBFORM,XBLINE,XBCOL+.5)=XBT
SET I=W
+6 IF XBT'["@"
Begin DoDot:1
+7 IF '$DATA(XBOUT(XBT))
QUIT
+8 IF $EXTRACT(XBOUT(XBT))=";"
SET XBOUT(XBT)=$$FMSUB(XBOUT(XBT))
+9 SET O=XBOUT(XBT)
SET XBT=$$SUB^XBFORM1(XBT,O)
+10 SET ^TMP($JOB,"XBFORM",XBFORM,XBLINE,XBCOL+.5)=XBT
+11 QUIT
End DoDot:1
QUIT
+12 SET XBV=$PIECE(XBT,"@")
SET XBV=XBVAR(XBV)
SET XBS=$PIECE(XBT,"@",2)
+13 IF $LENGTH(XBS)
SET XBS="("_XBS_")"
+14 SET ^TMP($JOB,"XBFORM",XBFORM,XBLINE,XBCOL+.5)=XBV_XBS
+15 IF $DATA(XBOUT(XBT))
Begin DoDot:1
+16 IF $EXTRACT(XBOUT(XBT))=";"
SET XBOUT(XBT)=$$FMSUB(XBOUT(XBT))
+17 SET O=XBOUT(XBT)
SET XBT=XBV_XBS
SET XBT=$$SUB^XBFORM1(XBT,O)
+18 SET ^TMP($JOB,"XBFORM",XBFORM,XBLINE,XBCOL+.5)=XBT
+19 QUIT
End DoDot:1
+20 QUIT
+21 ;
MAP ;** map shorthand for variables
+1 ;#xx1=yyy1|xx2=yyy2|
+2 SET Z=$EXTRACT(Z,2,999)
+3 IF Z'["|"
SET XBVSUB=$PIECE(Z,"=")
SET XBVAL=$PIECE(Z,"=",2)
SET XBVAR(XBVSUB)=XBVAL
QUIT
+4 FOR I=1:1
SET P=$PIECE(Z,"|",I)
IF P=""
QUIT
SET XBVSUB=$PIECE(P,"=")
SET XBVAL=$PIECE(P,"=",2)
SET XBVAR(XBVSUB)=XBVAL
+5 QUIT
+6 ;
OUT ;** output transform of data field
+1 ;*field:mumps output transform f(x)|
+2 SET Z=$EXTRACT(Z,2,999)
+3 IF Z'["|"
SET XBVSUB=$PIECE(Z,":")
SET XBVAL=$PIECE(Z,":",2,99)
SET XBOUT(XBVSUB)=XBVAL
QUIT
+4 FOR I=1:1
SET P=$PIECE(Z,"|",I)
IF P=""
QUIT
SET XBVSUB=$PIECE(P,":")
SET XBVAL=$PIECE(P,":",2,99)
SET XBOUT(XBVSUB)=XBVAL
+5 QUIT
+6 ;
TABS ;
+1 SET XBF="|....^...."
+2 WRITE #
+3 FOR I=0:1:7
WRITE ?I*10,I*10
+4 FOR L=1:1:66
WRITE !?1,L,?3,"..^...."
FOR X=1:1:7
WRITE XBF
+5 QUIT
+6 ;
EXIT ;
+1 KILL XBZ,XBFMT,XBCOL,XBCOLX,XBF,XBL,XBLINE,XBLN,XBLOAD,XBOUT,XBQUIT,XBROU,XBS,XBT,XBTAG,XBTAGE,XBV,XBVAL,XBVAR,XBVSUB,XBWP,XBWPDA,XBWPDIC,XBWPFLD,XBWPL,XBWPNODE,XBWPSUB,XBWWP,XBX,XBXL,XBRVL,XBLWP,XBLMMRK
+2 KILL XBLIN,XBLIN0,XBLIN1,XBLINX
+3 QUIT
+4 ;
MDY(X) ;external date to mm/dd/yy x :: var or ~"NOW"~ or ~"TODAY"~
+1 SET %DT="TS"
+2 DO ^%DT
+3 ;begin Y2K fix block
+4 ;S X=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)
+5 ;Y2000
SET X=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_($EXTRACT(Y,1,3)+1700)
+6 ;end Y2K fix block
+7 QUIT X
+8 ;
WP(X) ;build wp entry X #:: WP(FLD,n)=TEXTn
+1 NEW I,W
+2 SET XBLWP=$GET(XBLLINE)
SET W=$PIECE(X,")")
+3 FOR I=0:1
SET X=$QUERY(@X)
IF X=""
QUIT
IF (W'=$PIECE(X,","))
QUIT
Begin DoDot:1
+4 SET T=@X
SET XBLLINE=XBLWP+I
+5 IF '$GET(XBFMT)
SET XBZ(XBL+XBLLINE)=T
+6 IF ($GET(XBFMT)=1)
SET XBZ(XBL+XBLLINE,0)=T
+7 QUIT
End DoDot:1
+8 QUIT ""
+9 ;
FL(X) ; FL fill lines until line X
+1 NEW I,W
+2 SET XBLWP=$GET(XBLLINE)
+3 IF ((XBLLINE+XBL)'<X)
QUIT ""
+4 FOR XBLLINE=XBLLINE:1:X-XBL
Begin DoDot:1
+5 SET T=" "
+6 IF '$GET(XBFMT)
SET XBZ(XBL+XBLLINE)=T
+7 IF ($GET(XBFMT)=1)
SET XBZ(XBL+XBLLINE,0)=T
+8 QUIT
End DoDot:1
+9 QUIT ""
+10 ;
FMSUB(X) ;process popular ;D8 ;L20 ;R20
+1 NEW BARC,BARP
+2 SET BARC=$EXTRACT(X,2)
SET BARP=$EXTRACT(X,3,999)
+3 IF BARC="D"
SET X="$J(X,"_BARP_",2)"
QUIT X
+4 IF BARC="L"
SET X="$E(X,1,"_BARP_")"
QUIT X
+5 IF BARC="R"
SET X="$J(X,"_BARP_")"
QUIT X
+6 SET X="X"
+7 QUIT X
+8 ;
