Routine: BMXRPC2

BMXRPC2 ; IHS/OIT/HMW - FIELD LIST ;

 ;;4.0;BMX;;JUN 28, 2010

FLDLIST(BMXGBL,BMXFL,BMXATTR,BMXSCR)        ;EP

 ;TODO: Change all this to be a hard-coded $O thru ^DD

 ;Returns info in BMXATTR for all fields in file number BMXFL

 ;BMXSCR is executable code to set $T

 ; When BMXSCR is executed, the field number is in BMXFLD

 ;See FileMan documentation for FIELD^DD for description

 ;of Attributes

 ;---> Set variables, kill temp globals.

 ;S ^HW("F",BMXFL)=""

 ;S ^HW("F",BMXATTR)=""

 N BMX31,BMXERR,BMXG,BMXFLD,BMX,BMXC,BMXT

 S BMX31=$C(31)_$C(31)

 S BMXGBL="BMXTMP("_$J_")",BMXERR="",U="^"

 K BMXTMP($J)

 ;---> If file number not provided, return error.

 ;I '+BMXFL D ERROUT^BMXRPC("File number not provided.",1) Q

 ;---> If file number not provided check for file name.

 I +BMXFL'=BMXFL D

 . S BMXFL=$TR(BMXFL,"_"," ")

 . I '$D(^DIC("B",BMXFL)) S BMXFL="" Q

 . S BMXFL=$O(^DIC("B",BMXFL,0))

 I '$G(BMXFL) D ERROUT^BMXRPC("File number not provided.",1) Q

 ;---> If no such file, return error.

 I '$D(^DD(BMXFL,0)) D ERROUT^BMXRPC("File does not exist.",1) Q

 ;---> Validate screen code

 I $G(BMXSCR)="" S BMXSCR="I 1"

 S X=$G(BMXSCR)

 I X]"" D ^DIM

 I '$D(X) S BMXSCR="I 1" ;Default to no screen

 ;---> Set Target Global for output and errors.

 S BMXG="BMXTMP($J,""DID"")"

 ;---> Loop through ^DD(FileNumber,FieldNumber,0) to get field names

 K BMXTMP($J)

 I $G(BMXATTR)="" S BMXATTR="LABEL" ;Changed from NAME to LABEL

 ;---> Attribute Names

 F I=1:1:$L(BMXATTR,";") S BMXT($P(BMXATTR,";",I))=""

 S (BMX,BMXC)=0 F  S BMX=$O(BMXT(BMX)) Q:BMX=""  D

 . S BMXC=BMXC+1

 . S $P(BMXT,U,BMXC)="T00030"_BMX

 S BMXTMP($J,1)="T00030NUMBER"_U_BMXT_$C(30)

 ;S BMXFLD=0 F I=2:1 S BMXFLD=$O(^DD(BMXFL,BMXFLD)) Q:'+BMXFLD  D

 S BMXTMP($J,2)=".001^BMXIEN"_$C(30)

 S BMXFLDN=0 F I=3:1 S BMXFLDN=$O(^DD(BMXFL,"B",BMXFLDN)) Q:BMXFLDN=""  D

 . S BMXFLD=$O(^DD(BMXFL,"B",BMXFLDN,0)) Q:'+BMXFLD

 . X BMXSCR Q:'$T

 . D FIELD^DID(BMXFL,BMXFLD,,BMXATTR,BMXG,BMXG)

 . K BMXT S (BMXC,BMX)=0

 . F  S BMX=$O(BMXTMP($J,"DID",BMX)) Q:BMX=""  D

 . . S BMXC=BMXC+1

 . . S $P(BMXT,U,BMXC)=BMXTMP($J,"DID",BMX)

 . S BMXTMP($J,I)=BMXFLD_U_$TR(BMXT," ","_")_$C(30)

 ;S I=I+1,BMXTMP($J,I)=".001^BMXIEN"_$C(30)

 S I=I+1

 K BMXTMP($J,"DID")

 ;---> Tack on Error Delimiter and any error.

 S BMXTMP($J,I)=BMX31_BMXERR

MLTLIST(BMXGBL,BMXFL,BMXONEOK) ;EP

 ;Returns list of multiple fields in file BMXFL, returns only one field

 ;if BMXONEOK is TRUE

 ;S ^HW($H,"MLTLIST","FL")=BMXFL

 ;S ^HW($H,"MLTLIST","ONE")=BMXONEOK

 N BMX31,BMXERR,BMXG,BMXFLD,BMX,BMXC,BMXT,I

 S BMX31=$C(31)_$C(31)

 S BMXGBL="BMXTMP("_$J_")",BMXERR="",U="^"

 K BMXTMP($J)

 ;---> If file number not provided check for file name.

 I +BMXFL'=BMXFL D

 . S BMXFL=$TR(BMXFL,"_"," ")

 . I '$D(^DIC("B",BMXFL)) S BMXFL="" Q

 . S BMXFL=$O(^DIC("B",BMXFL,0))

 I '$G(BMXFL) D ERROUT^BMXRPC("File number not provided.",1) Q

 ;---> If no such file, return error.

 I '$D(^DD(BMXFL,0)) D ERROUT^BMXRPC("File does not exist.",1) Q

 ;---> Column Headers

 S BMXTMP($J,1)="T00030NUMBER"_U_"T00030NAME"_$C(30)

 ;---> $O thru ^DD(BMXFL,"SB" to get subfile numbers and names

 S I=2

 N BMXSB,BMXSBN,BMXSBF,BMXFOUND

 S BMXFOUND=0

 I $D(^DD(BMXFL,"SB")) D

 . S BMXSB=0

 . F  S BMXSB=$O(^DD(BMXFL,"SB",BMXSB)) Q:'+BMXSB  D  I BMXFOUND Q:BMXONEOK=1

 . . S BMXSBF=$O(^DD(BMXFL,"SB",BMXSB,0))

 . . Q:'+BMXSBF

 . . S BMXSBN=$G(^DD(BMXFL,BMXSBF,0))

 . . Q:BMXSBN=""

 . . S BMXZ=$G(^DD(BMXSB,.01,0))

 . . Q:$P(BMXZ,U,2)["W"

 . . S BMXFOUND=1

 . . S BMXSBN=$P(BMXSBN,U)

 . . S BMXTMP($J,I)=BMXSB_U_BMXSBN_$C(30)

 . . S I=I+1

 ;---> Tack on Error Delimiter and any error.

 S BMXTMP($J,I)=BMX31_BMXERR

BMXRPC2   ; IHS/OIT/HMW - FIELD LIST ;

 +1       ;;4.0;BMX;;JUN 28, 2010

 +2       ;

FLDLIST(BMXGBL,BMXFL,BMXATTR,BMXSCR) ;EP

 +1       ;TODO: Change all this to be a hard-coded $O thru ^DD

 +2       ;Returns info in BMXATTR for all fields in file number BMXFL

 +3       ;BMXSCR is executable code to set $T

 +4       ; When BMXSCR is executed, the field number is in BMXFLD

 +5       ;See FileMan documentation for FIELD^DD for description

 +6       ;of Attributes

 +7       ;

 +8       ;---> Set variables, kill temp globals.

 +9       ;S ^HW("F",BMXFL)=""

 +10      ;S ^HW("F",BMXATTR)=""

 +11       NEW BMX31,BMXERR,BMXG,BMXFLD,BMX,BMXC,BMXT

 +12       SET BMX31=$CHAR(31)_$CHAR(31)

 +13       SET BMXGBL="BMXTMP("_$JOB_")"

           SET BMXERR=""

           SET U="^"

 +14       KILL BMXTMP($JOB)

 +15      ;

 +16      ;---> If file number not provided, return error.

 +17      ;I '+BMXFL D ERROUT^BMXRPC("File number not provided.",1) Q

 +18      ;---> If file number not provided check for file name.

 +19       IF +BMXFL'=BMXFL

               Begin DoDot:1

 +20               SET BMXFL=$TRANSLATE(BMXFL,"_"," ")

 +21               IF '$DATA(^DIC("B",BMXFL))

                       SET BMXFL=""

                       QUIT

 +22               SET BMXFL=$ORDER(^DIC("B",BMXFL,0))

               End DoDot:1

 +23       IF '$GET(BMXFL)

               DO ERROUT^BMXRPC("File number not provided.",1)

               QUIT

 +24      ;

 +25      ;---> If no such file, return error.

 +26       IF '$DATA(^DD(BMXFL,0))

               DO ERROUT^BMXRPC("File does not exist.",1)

               QUIT

 +27      ;

 +28      ;---> Validate screen code

 +29       IF $GET(BMXSCR)=""

               SET BMXSCR="I 1"

 +30       SET X=$GET(BMXSCR)

 +31       IF X]""

               DO ^DIM

 +32      ;Default to no screen

           IF '$DATA(X)

               SET BMXSCR="I 1"

 +33      ;

 +34      ;---> Set Target Global for output and errors.

 +35       SET BMXG="BMXTMP($J,""DID"")"

 +36      ;

 +37      ;---> Loop through ^DD(FileNumber,FieldNumber,0) to get field names

 +38       KILL BMXTMP($JOB)

 +39      ;Changed from NAME to LABEL

           IF $GET(BMXATTR)=""

               SET BMXATTR="LABEL"

 +40      ;---> Attribute Names

 +41       FOR I=1:1:$LENGTH(BMXATTR,";")

               SET BMXT($PIECE(BMXATTR,";",I))=""

 +42       SET (BMX,BMXC)=0

FOR

               SET BMX=$ORDER(BMXT(BMX))

               IF BMX=""

                   QUIT

               Begin DoDot:1

 +43               SET BMXC=BMXC+1

 +44               SET $PIECE(BMXT,U,BMXC)="T00030"_BMX

               End DoDot:1

 +45       SET BMXTMP($JOB,1)="T00030NUMBER"_U_BMXT_$CHAR(30)

 +46      ;

 +47      ;S BMXFLD=0 F I=2:1 S BMXFLD=$O(^DD(BMXFL,BMXFLD)) Q:'+BMXFLD  D

 +48       SET BMXTMP($JOB,2)=".001^BMXIEN"_$CHAR(30)

 +49       SET BMXFLDN=0

           FOR I=3:1

               SET BMXFLDN=$ORDER(^DD(BMXFL,"B",BMXFLDN))

               IF BMXFLDN=""

                   QUIT

               Begin DoDot:1

 +50               SET BMXFLD=$ORDER(^DD(BMXFL,"B",BMXFLDN,0))

                   IF '+BMXFLD

                       QUIT

 +51               XECUTE BMXSCR

                   IF '$TEST

                       QUIT

 +52               DO FIELD^DID(BMXFL,BMXFLD,,BMXATTR,BMXG,BMXG)

 +53               KILL BMXT

                   SET (BMXC,BMX)=0

 +54               FOR

                       SET BMX=$ORDER(BMXTMP($JOB,"DID",BMX))

                       IF BMX=""

                           QUIT

                       Begin DoDot:2

 +55                       SET BMXC=BMXC+1

 +56                       SET $PIECE(BMXT,U,BMXC)=BMXTMP($JOB,"DID",BMX)

                       End DoDot:2

 +57               SET BMXTMP($JOB,I)=BMXFLD_U_$TRANSLATE(BMXT," ","_")_$CHAR(30)

               End DoDot:1

 +58      ;S I=I+1,BMXTMP($J,I)=".001^BMXIEN"_$C(30)

 +59       SET I=I+1

 +60       KILL BMXTMP($JOB,"DID")

 +61      ;---> Tack on Error Delimiter and any error.

 +62       SET BMXTMP($JOB,I)=BMX31_BMXERR

 +63       QUIT

 +64      ;

MLTLIST(BMXGBL,BMXFL,BMXONEOK) ;EP

 +1       ;Returns list of multiple fields in file BMXFL, returns only one field

 +2       ;if BMXONEOK is TRUE

 +3       ;S ^HW($H,"MLTLIST","FL")=BMXFL

 +4       ;S ^HW($H,"MLTLIST","ONE")=BMXONEOK

 +5        NEW BMX31,BMXERR,BMXG,BMXFLD,BMX,BMXC,BMXT,I

 +6        SET BMX31=$CHAR(31)_$CHAR(31)

 +7        SET BMXGBL="BMXTMP("_$JOB_")"

           SET BMXERR=""

           SET U="^"

 +8        KILL BMXTMP($JOB)

 +9       ;

 +10      ;---> If file number not provided check for file name.

 +11       IF +BMXFL'=BMXFL

               Begin DoDot:1

 +12               SET BMXFL=$TRANSLATE(BMXFL,"_"," ")

 +13               IF '$DATA(^DIC("B",BMXFL))

                       SET BMXFL=""

                       QUIT

 +14               SET BMXFL=$ORDER(^DIC("B",BMXFL,0))

               End DoDot:1

 +15       IF '$GET(BMXFL)

               DO ERROUT^BMXRPC("File number not provided.",1)

               QUIT

 +16      ;

 +17      ;---> If no such file, return error.

 +18       IF '$DATA(^DD(BMXFL,0))

               DO ERROUT^BMXRPC("File does not exist.",1)

               QUIT

 +19      ;

 +20      ;---> Column Headers

 +21       SET BMXTMP($JOB,1)="T00030NUMBER"_U_"T00030NAME"_$CHAR(30)

 +22      ;

 +23      ;---> $O thru ^DD(BMXFL,"SB" to get subfile numbers and names

 +24       SET I=2

 +25       NEW BMXSB,BMXSBN,BMXSBF,BMXFOUND

 +26       SET BMXFOUND=0

 +27       IF $DATA(^DD(BMXFL,"SB"))

               Begin DoDot:1

 +28               SET BMXSB=0

 +29               FOR

                       SET BMXSB=$ORDER(^DD(BMXFL,"SB",BMXSB))

                       IF '+BMXSB

                           QUIT

                       Begin DoDot:2

 +30                       SET BMXSBF=$ORDER(^DD(BMXFL,"SB",BMXSB,0))

 +31                       IF '+BMXSBF

                               QUIT

 +32                       SET BMXSBN=$GET(^DD(BMXFL,BMXSBF,0))

 +33                       IF BMXSBN=""

                               QUIT

 +34                       SET BMXZ=$GET(^DD(BMXSB,.01,0))

 +35                       IF $PIECE(BMXZ,U,2)["W"

                               QUIT

 +36                       SET BMXFOUND=1

 +37                       SET BMXSBN=$PIECE(BMXSBN,U)

 +38                       SET BMXTMP($JOB,I)=BMXSB_U_BMXSBN_$CHAR(30)

 +39                       SET I=I+1

                       End DoDot:2

                       IF BMXFOUND

                           IF BMXONEOK=1

                               QUIT

               End DoDot:1

 +40      ;

 +41      ;---> Tack on Error Delimiter and any error.

 +42       SET BMXTMP($JOB,I)=BMX31_BMXERR

 +43       QUIT

BMXRPC2.m