XBFORM1.m

XBFORM1 ; IHS/ADC/GTH - sub x in output transforms  [ 02/07/97   3:02 PM ]

 ;;3.0;IHS/VA UTILITIES;;FEB 07, 1997

 ;

 ;XBV1=NEW CODE,XBLINX=original out transform

 Q

 ;

SUB(XBV1,XBLINX) ;EP extrensic to return new  output transform 

 D EN^XBNEW("XSUB^XBFORM1","XBV1;XBLINX")

 Q XBLINX

 ;

XSUB ;EP - do it

 NEW XB,XBT

 D SCAN

 I 'XBMK Q

 S XBLIN=XBLINX

 D BLDLIN1

 S XBLINX=XBLIN1

 Q

 ;

 ;----------------- SUB ROUTINES ---------------

 ;

SCAN ;EP - scan for X

 S XBVX="X"

 S XBP=" #&'()*+,'-/<=>@\_?;:[]!""",XBS=XBP

 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 ;

 S XBMK="",XBJM=""

 F  S XBJM=$O(XB(XBJM)) Q:XBJM=""  I $G(XB(XBJM,"M")) S XBMK=1 Q

 KILL XBJM

SCANE ;

 Q

 ;

BLDLIN1 ;

 S XBLIN=XBLINX,XBV0="X"

 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)

BLDLIN1E ;

 Q

 ;

XBFORM1   ; IHS/ADC/GTH - sub x in output transforms  [ 02/07/97   3:02 PM ]

 +1       ;;3.0;IHS/VA UTILITIES;;FEB 07, 1997

 +2       ;

 +3       ;XBV1=NEW CODE,XBLINX=original out transform

 +4        QUIT 

 +5       ;

SUB(XBV1,XBLINX) ;EP extrensic to return new  output transform 

 +1        DO EN^XBNEW("XSUB^XBFORM1","XBV1;XBLINX")

 +2        QUIT XBLINX

 +3       ;

XSUB      ;EP - do it

 +1        NEW XB,XBT

 +2        DO SCAN

 +3        IF 'XBMK

               QUIT 

 +4        SET XBLIN=XBLINX

 +5        DO BLDLIN1

 +6        SET XBLINX=XBLIN1

 +7        QUIT 

 +8       ;

 +9       ;----------------- SUB ROUTINES ---------------

 +10      ;

SCAN      ;EP - scan for X

 +1        SET XBVX="X"

 +2        SET XBP=" #&'()*+,'-/<=>@\_?;:[]!"""

           SET XBS=XBP

 +3        SET XBL=$LENGTH(XBVX)

 +4        FOR XBI=1:1

               SET XB(XBI)=$FIND(XBLINX,XBVX,$GET(XB(XBI-1))+1)-XBL

               IF XB(XBI)'>0

                   QUIT 

               Begin DoDot:1

 +5                SET XB(XBI,"M")=0

                   SET XB(XBI,0)=XB(XBI)

 +6                IF XBP[$EXTRACT(XBLINX,XB(XBI)-1)

                       IF XBS[$EXTRACT(XBLINX,XB(XBI)+XBL)

                           SET XB(XBI,"M")=1

 +7                SET XB("B",XB(XBI))=XBI

                   SET XB("E",XB(XBI)+XBL-1)=XBI

 +8                SET XB(XBI,"E")=XB(XBI)+XBL-1

 +9                QUIT 

               End DoDot:1

 +10       KILL XB(XBI)

CHKMK     ;

 +1        SET XBMK=""

           SET XBJM=""

 +2        FOR 

               SET XBJM=$ORDER(XB(XBJM))

               IF XBJM=""

                   QUIT 

               IF $GET(XB(XBJM,"M"))

                   SET XBMK=1

                   QUIT 

 +3        KILL XBJM

SCANE     ;

 +1        QUIT 

 +2       ;

BLDLIN1   ;

 +1        SET XBLIN=XBLINX

           SET XBV0="X"

 +2        SET XBLIN0=XBLIN

           SET XBSUB=XBV0_":"_XBV1

           SET XBLIN1=""

 +3        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)

 +4        SET XBI=XBI-1

           SET XBLIN1=XBLIN1_$EXTRACT(XBLIN,XB(XBI,"E")+1,999)

BLDLIN1E  ;

 +1        QUIT 

 +2       ;