203 lines
5.4 KiB
Mathematica
203 lines
5.4 KiB
Mathematica
XBFORM ; IHS/ADC/GTH - BUILD ARRAY FROM WP FORMAT ; [ 07/08/1999 3:53 PM ]
|
|
;;4.0;XB;;Jul 20, 2009;Build 2
|
|
;
|
|
; 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
|
|
;
|