Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XBFORM

XBFORM.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  ; Please refer to routine XBFORM0 for documentation.
  1.  ;
  1.  Q
  1.  ;
  1. EDIT(XBFORM,XBWPDIC,XBWPFLD) ;EP  Edit a Form
  1. EDIT2 ;
  1.  KILL ^TMP($J,"XBFORM",XBFORM)
  1.  S XBLLINE=0,XBFMT=1
  1.  I $D(XBLMMRK) S XBLMMARK=XBLMMRK
  1.  I '$D(XBLMMARK) S XBLMMARK=$$DIR^XBDIR("Y","MARKERS ","N")
  1.  S XBLMMRK=XBLMMARK
  1.  D EDITWP,WPGET,BUILD,ZBUILD
  1.  ;** add RV markers
  1.  I '$D(XBLMMARK) S XBLMMARK=$$DIR^XBDIR("Y","MARKERS ","N")
  1.  I $D(DIRUT) D EXIT KILL XBLLINE Q
  1. MARK ;
  1.  I $G(XBLMMARK) F XBRVL=5:5 Q:'$D(XBZ(XBRVL))  S:'(XBRVL#10) $E(XBZ(XBRVL,0),80)=$E(XBRVL)
  1.  KILL XBRVL
  1.  D ARRAY^XBLM("XBZ(",XBFORM),CLEAR^VALM1
  1.  I $$DIR^XBDIR("S^R:Re-Edit;Q:Quit")="R" KILL XBZ G EDIT2
  1.  D EXIT
  1.  KILL XBLLINE
  1.  Q
  1.  ;
  1. GEN(XBFORM,XBWPDIC,XBWPFLD,XBREF,XBFMT,XBLAST) ;EP  ** generate array 
  1.  NEW XBLLINE
  1.  S XBLLINE=$G(XBLAST)
  1.  I $D(^TMP($J,"XBFORM",XBFORM)) D ZBUILD,REFBUILD,EXIT Q XBLLINE
  1.  D WPGET,BUILD,ZBUILD,REFBUILD,EXIT
  1.  Q XBLLINE
  1.  ;
  1. EDITWP ;** edit WP array
  1.  KILL DIE,DIC,DA,DR
  1.  S DIC=XBWPDIC,DR=XBWPFLD,DIC(0)="AEQMLZ"
  1.  I $L($G(XBFORM))>0 S X=XBFORM,DIC(0)="XL"
  1.  D ^DIC
  1.  I Y'>0 S XBQUIT=1 Q
  1.  S DIE=$$DIC^XBDIQ1(XBWPDIC),DA=+Y,DR=XBWPFLD
  1.  D ^DIE
  1.  Q
  1.  ;
  1. WPGET ;** get WP array
  1.  KILL XBWP,XBL,XBOUT,XBVAR,XBWWP,DIC,DR,DIE,DA
  1.  S X=XBFORM,DIC=XBWPDIC,DR=XBWPFLD,DIC(0)="X"
  1.  D ^DIC
  1.  I Y'>0 S XBWP(1)=XBFORM_"  NOT FOUND",XBQUIT=1
  1.  S DA=+Y
  1.  D ENP^XBDIQ1(XBWPDIC,DA,XBWPFLD,"XBWWP(")
  1.  S %X="XBWWP("_XBWPFLD_",",%Y="XBWP("
  1.  D %XY^%RCR
  1.  KILL XBWWP
  1.  Q
  1.  ;
  1. BUILD ;** scan WP array to build XBL
  1.  S XBWPL="",XBLINE=0
  1.  Q:$D(^TMP($J,"XBFORM",XBFORM))
  1.  F  S XBWPL=$O(XBWP(XBWPL)) Q:XBWPL'>0  D LINE
  1.  Q
  1.  ;
  1. LINE ;** process one line of the WP array    
  1.  S Z=XBWP(XBWPL),XBLINE=XBLINE+1
  1.  F I=1:1:$L(Z) S A=$E(Z,I) D  Q:$G(XBQUIT)
  1.  . I I=1,A="#" D MAP S I=$L(Z),XBLINE=XBLINE-1,XBQUIT=1 Q
  1.  . I I=1,A="*" D OUT S I=$L(Z),XBLINE=XBLINE-1,XBQUIT=1 Q
  1.  . I I=1,A=";" S I=$L(Z),XBLINE=XBLINE-1,XBQUIT=1 Q
  1.  . I A'=" ",A'="|" D TEXT Q
  1.  . I A="|" D VAR Q
  1.  .Q
  1.  KILL XBQUIT
  1.  Q
  1.  ;
  1. ZBUILD ;** build Z array from XBL
  1.  KILL Z
  1.  I '$G(XBFMT) F XBL=1:1 D  Q:('$O(^TMP($J,"XBFORM",XBFORM,XBL)))
  1.  . I '$D(^TMP($J,"XBFORM",XBFORM,XBL)),$O(^TMP($J,"XBFORM",XBFORM,XBL)) S XBZ(XBL+XBLLINE)=" " Q
  1.  . D FILL
  1.  .Q
  1.  I $G(XBFMT)=1 F XBL=1:1 D  Q:('$O(^TMP($J,"XBFORM",XBFORM,XBL)))
  1.  . I '$D(^TMP($J,"XBFORM",XBFORM,XBL)),$O(^TMP($J,"XBFORM",XBFORM,XBL)) S XBZ(XBL+XBLLINE,0)=" " Q
  1.  . D FILL
  1.  .Q
  1.  Q
  1.  ;
  1. REFBUILD ; %RCR BACK TO CALL
  1.  S %Y=XBREF,%X="XBZ("
  1.  D %XY^%RCR
  1.  S XBLLINE=XBLLINE+XBL
  1.  Q
  1.  ;
  1. FILL ;** fill one line
  1.  S XBCOL=0,T=""
  1.  F  S XBCOL=$O(^TMP($J,"XBFORM",XBFORM,XBL,XBCOL)) Q:XBCOL'>0  D
  1.  . S X=^TMP($J,"XBFORM",XBFORM,XBL,XBCOL)
  1.  . S XBCOLX=XBCOL
  1.  . I XBCOL#1 S XBCOLX=XBCOL\1,X="S X="_X X X
  1.  . S XBXL=$L(X)
  1.  . Q:X=""
  1.  . S T=$$SETSTR^VALM1(X,T,XBCOLX,XBXL)
  1.  .Q
  1.  I T="" S XBLLINE=$G(XBLLINE)-1 Q
  1.  S:'$G(XBFMT) XBZ(XBL+XBLLINE)=T
  1.  S:($G(XBFMT)=1) XBZ(XBL+XBLLINE,0)=T
  1.  Q
  1.  ;
  1. TEXT ;**    
  1.  NEW W
  1.  S XBCOL=I
  1.  F W=I:1:$L(Z) S A=$E(Z,W) Q:A="|"
  1.  I W'=$L(Z) S W=W-1
  1.  S XBT=$E(Z,I,W),^TMP($J,"XBFORM",XBFORM,XBLINE,XBCOL)=XBT,I=W
  1.  Q
  1.  ;
  1. VAR ;** add .5 to column count to indicate a variable vs text
  1.  S XBCOL=I
  1.  F W=I+1:1:$L(Z) S A=$E(Z,W) I A="|" Q
  1.  S XBT=$E(Z,I+1,W-1)
  1.  I XBT="" S XBT="""|"""
  1.  S ^TMP($J,"XBFORM",XBFORM,XBLINE,XBCOL+.5)=XBT,I=W
  1.  I XBT'["@" D  Q
  1.  . Q:'$D(XBOUT(XBT))
  1.  . I $E(XBOUT(XBT))=";" S XBOUT(XBT)=$$FMSUB(XBOUT(XBT))
  1.  . S O=XBOUT(XBT),XBT=$$SUB^XBFORM1(XBT,O)
  1.  . S ^TMP($J,"XBFORM",XBFORM,XBLINE,XBCOL+.5)=XBT
  1.  .Q
  1.  S XBV=$P(XBT,"@"),XBV=XBVAR(XBV),XBS=$P(XBT,"@",2)
  1.  I $L(XBS) S XBS="("_XBS_")"
  1.  S ^TMP($J,"XBFORM",XBFORM,XBLINE,XBCOL+.5)=XBV_XBS
  1.  I $D(XBOUT(XBT)) D
  1.  . I $E(XBOUT(XBT))=";" S XBOUT(XBT)=$$FMSUB(XBOUT(XBT))
  1.  . S O=XBOUT(XBT),XBT=XBV_XBS,XBT=$$SUB^XBFORM1(XBT,O)
  1.  . S ^TMP($J,"XBFORM",XBFORM,XBLINE,XBCOL+.5)=XBT
  1.  .Q
  1.  Q
  1.  ;
  1. MAP ;** map shorthand for variables      
  1.  ;#xx1=yyy1|xx2=yyy2|
  1.  S Z=$E(Z,2,999)
  1.  I Z'["|" S XBVSUB=$P(Z,"="),XBVAL=$P(Z,"=",2),XBVAR(XBVSUB)=XBVAL Q
  1.  F I=1:1 S P=$P(Z,"|",I) Q:P=""  S XBVSUB=$P(P,"="),XBVAL=$P(P,"=",2),XBVAR(XBVSUB)=XBVAL
  1.  Q
  1.  ;
  1. OUT ;** output transform of data field
  1.  ;*field:mumps output transform f(x)|
  1.  S Z=$E(Z,2,999)
  1.  I Z'["|" S XBVSUB=$P(Z,":"),XBVAL=$P(Z,":",2,99),XBOUT(XBVSUB)=XBVAL Q
  1.  F I=1:1 S P=$P(Z,"|",I) Q:P=""  S XBVSUB=$P(P,":"),XBVAL=$P(P,":",2,99),XBOUT(XBVSUB)=XBVAL
  1.  Q
  1.  ;
  1. TABS ;
  1.  S XBF="|....^...."
  1.  W #
  1.  F I=0:1:7 W ?I*10,I*10
  1.  F L=1:1:66 W !?1,L,?3,"..^...." F X=1:1:7 W XBF
  1.  Q
  1.  ;
  1. 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
  1.  KILL XBLIN,XBLIN0,XBLIN1,XBLINX
  1.  Q
  1.  ;
  1. MDY(X) ;external date to mm/dd/yy    x :: var or ~"NOW"~ or ~"TODAY"~
  1.  S %DT="TS"
  1.  D ^%DT
  1.  ;begin Y2K fix block
  1.  ;S X=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)
  1.  S X=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_($E(Y,1,3)+1700) ;Y2000
  1.  ;end Y2K fix block
  1.  Q X
  1.  ;
  1. WP(X) ;build wp entry   X #:: WP(FLD,n)=TEXTn
  1.  NEW I,W
  1.  S XBLWP=$G(XBLLINE),W=$P(X,")")
  1.  F I=0:1 S X=$Q(@X) Q:X=""  Q:(W'=$P(X,","))  D
  1.  . S T=@X,XBLLINE=XBLWP+I
  1.  . S:'$G(XBFMT) XBZ(XBL+XBLLINE)=T
  1.  . S:($G(XBFMT)=1) XBZ(XBL+XBLLINE,0)=T
  1.  .Q
  1.  Q ""
  1.  ;
  1. FL(X) ; FL fill lines until line X
  1.  NEW I,W
  1.  S XBLWP=$G(XBLLINE)
  1.  Q:((XBLLINE+XBL)'<X) ""
  1.  F XBLLINE=XBLLINE:1:X-XBL  D
  1.  . S T=" "
  1.  . S:'$G(XBFMT) XBZ(XBL+XBLLINE)=T
  1.  . S:($G(XBFMT)=1) XBZ(XBL+XBLLINE,0)=T
  1.  .Q
  1.  Q ""
  1.  ;
  1. FMSUB(X) ;process popular ;D8 ;L20 ;R20
  1.  NEW BARC,BARP
  1.  S BARC=$E(X,2),BARP=$E(X,3,999)
  1.  I BARC="D" S X="$J(X,"_BARP_",2)" Q X
  1.  I BARC="L" S X="$E(X,1,"_BARP_")" Q X
  1.  I BARC="R" S X="$J(X,"_BARP_")" Q X
  1.  S X="X"
  1.  Q X
  1.  ;