MCDBELM.m

MCDBELM ;WISC/DCB-save and load util.  ;8/15/96  09:52

 ;;2.3;Medicine;;09/13/1996

 Q

RTNELM(FILE,REC,FIELDS,EXC,DATA,TYPE,USER,TEMP,ERROR) ;RTN the elements in an array

 N Y,X,BACK,FILES,FLDS,RECS,XFILE,XREC,XFLD,HOLD,FLD,TOTAL

 N COUNT,COUNT2,XTEMP,XTFILE,TMP,TMP1,TMP2 S ERROR=""

 S FILE=$$RTNFILE(FILE,FIELDS) Q:$E(FILE,1)=" " FILE

 F TOTAL=1:1:255 S XFILE=$P(FILE,U,TOTAL),XREC=$P(REC,U,TOTAL),XFLD=$P(FIELDS,U,TOTAL) Q:(XREC_XFLD)=""  S TEMP(TOTAL)=XFILE_U_XREC_U_XFLD

 S TOTAL=TOTAL-1

 F COUNT=1:1:TOTAL Q:ERROR'=""  D

 .S XTEMP=TEMP(COUNT) S:COUNT>1 BACK=TEMP(COUNT-1)

 .S XFILE=+$P(XTEMP,U),XREC=+$P(XTEMP,U,2),XFLD=$P(XTEMP,U,3)

 .I XFILE<1 S ERROR=" 2.1 - (Sub)File is less than 1 or null" Q

 .I XREC<1 S ERROR=" 2.2 - (Sub)Record is less than 1 or null" Q

 .I '$D(^DD(XFILE)) S ERROR=" 2.3 - (Sub)File is not define" Q 

 .I COUNT>1 S HOLD=+$P($G(^DD(+$P(BACK,U,1),+$P(BACK,U,3),0)),U,2) I XFILE'=HOLD S ERROR=" 2.4 - Subfile missing in Data Dictionary" Q

 .F COUNT2=1:1:255 S FLD=$P(XFLD,";",COUNT2) Q:FLD=""!(ERROR'="")  D

 ..I +FLD=0 S ERROR=" 2.5 - (Sub)Field is zero or null"

 ..S:'$D(^DD(XFILE,FLD)) ERROR=" 2.6 - (Sub)Field is not defined in DD"

 ..I COUNT=TOTAL S TEMP("FLD",FLD)=$P(DATA,"|",COUNT2),TEMP("TYP",FLD)=$P(TYPE,U,COUNT2),TEMP("FLDNAME",FLD)=$P(^DD(XFILE,FLD,0),U,1)

 ..S (TEMP("EXC",FLD),X)=$G(EXC(FLD))

 ..D:X ^DIM  S:'$D(X) ERROR=" 2.7 Syntax error in the Execption Code"

 S TEMP("X")=$P(TEMP(TOTAL),U,3)

 S TEMP("XF")=$P(TEMP(TOTAL),U,1)

 S TEMP("USER")=+$G(USER)

 S TEMP("DIC")=$$RTNDIE(.TEMP)

 S BACK=$L(TEMP("DIC"))

 S HOLD=$E(TEMP("DIC"),1,BACK-1)

 S TEMP("GLO")=HOLD_$S($E(TEMP("DIC"),BACK)=",":")",1:"")

 S:$E(TEMP("DIC"),1)=" " ERROR=TEMP("DIC")

 Q

RTNFILE(FILE,FIELDS) ;Get the Subfile -This is used og RTELM-

 N XCOUNT,XFILE,ERROR,XTMP,XFLD,XSFILE,XFLDN,XTFILE,XTMP2

 S (XSFILE,XTFILE)=+FILE,ERROR=""

 F XCOUNT=1:1:255 S XFLD=$P(FIELDS,U,XCOUNT),XTMP2=$P(FIELDS,U,XCOUNT+1) Q:XTMP2=""!(ERROR'="")  D

 .S XTMP=$G(^DD(XTFILE,+XFLD,0)) I XTMP="" S ERORR=" Field not in DD" Q

 .S XTFILE=+$P(XTMP,U,2) I '$D(^DD(XTFILE)) S ERROR=" Undefine (Sub)file"

 .S XSFILE=XSFILE_U_XTFILE

 Q $S(ERROR="":XSFILE,1:ERROR)

RTNDIE(TEMP) ;Return the DIE value

 N XFILE,XLOOP,XNODE,XBACK,ERROR S ERROR=""

 I '$D(TEMP) Q " 0.0 - Require array not define"

 S XFILE=$G(^DIC($P(+$G(TEMP(1)),U,1),0,"GL")),XLOOP=1

 Q:XFILE="" " 3.1 - Global location is not defined"

 F  S XLOOP=+$O(TEMP(XLOOP)) Q:XLOOP=0!(ERROR'="")  D

 .S XBACK=TEMP(XLOOP-1),XFILE=XFILE_$P(XBACK,U,2)_","

 .S XNODE=$G(^DD(+$P(XBACK,U,1),+$P(XBACK,U,3),0))

 .S XNODE=$P($P(XNODE,U,4),";",1)

 .I XNODE="" S ERROR=" 3.2 - The zero node of the DD is undefined" Q

 .I XNODE'=+XNODE S XNODE=""""_XNODE_"""" ; DAD 8-5-96

 .S XFILE=XFILE_XNODE_","

 S:ERROR="" ERROR=$$CHKFILE(XFILE)

 Q $S(ERROR="":XFILE,1:ERROR)

RTNDR(TEMP,TYPE) ;Return The DR value

 N XTYPE,XERROR,XFLD,XDR,XHLD,XDAT

 S TYPE=+$G(TYPE)

 I '$D(TEMP) Q " 0.0 - Require array not define"

 S XTYPE="///",(XERROR,XFLD,XDR)=""

 F  S XFLD=+$O(TEMP("FLD",XFLD)) Q:XFLD=0  D

 .I (TYPE=1),($G(TEMP("EXC",XHOLD))'=""),(ERROR'="") D

 ..S X=TEMP("FLD",FLD) X:X'="" TEMP("EXC",XHOLD)

 ..S:X'="" TEMP("FLD",FLD)=X

 .S XHLD=$G(TEMP("TYP",XFLD)),XHLD=$S(XHLD="":XTYPE,1:XHLD)

 .S XDAT=$G(TEMP("FLD",XFLD)),XDR=XDR_$S(XDR="":"",1:";")

 .S:TYPE=1 XDR=XDR_XFLD_$S(XDAT="":XTYPE,1:XHLD)_XDAT

 .S:TYPE=0 XDR=XDR_XFLD

 Q XDR

RTNDA(TEMP,ARRAY,ERROR) ;Return The DA value

 N HOLD,TOTAL,COUNT S ERROR="",TOTAL=$$TOTAL(.TEMP)

 I '$D(TEMP) Q " 0.0 - Require array not define"

 F COUNT=TOTAL:-1:1 Q:ERROR'=""  D

 .S ARRAY(TOTAL-COUNT)=+$P($G(TEMP(COUNT)),U,2)

 .S:ARRAY(TOTAL-COUNT)<1 ERROR=" 5.1 - Record is less than 1 or null"

 S ARRAY=ARRAY(0) K ARRAY(0)

 Q

STR(XTEMP) ;GET THE DATA VALUE (used by RTNELM)

 N TEMP,LOOP,HOLD

 S TEMP=$P(XTEMP,"/",2,255) F LOOP=1:1:4 Q:$E(TEMP,LOOP)'="/"

 S HOLD=$E(TEMP,LOOP,$L(TEMP))

 Q $S(HOLD="@":"",1:HOLD)

TOTAL(ARRAY) ;Find the total count in an array used by calls)

 N COUNT,TOTAL S (COUNT,TOTAL)=0

 F  S COUNT=+$O(TEMP(COUNT)) S:COUNT'=0 TOTAL=COUNT Q:COUNT=0

 Q TOTAL

CHKFILE(FILE) ;This validates if global reference is a fileMan file & exists

 N X S ERROR=""

 S X="S:'$D("_FILE_"0)) ERROR="" 6.1 (sub)file does not exist"""

 D ^DIM

 I '$D(X)!($E(FILE,1)'["^")!(($E(FILE,$L(FILE))'[",")&($E(FILE,$L(FILE))'["(")) S ERROR=" 7.1 Bad Global name for FileMan"

 Q ERROR

MCDBELM   ;WISC/DCB-save and load util.  ;8/15/96  09:52

 +1       ;;2.3;Medicine;;09/13/1996

 +2        QUIT 

RTNELM(FILE,REC,FIELDS,EXC,DATA,TYPE,USER,TEMP,ERROR) ;RTN the elements in an array

 +1        NEW Y,X,BACK,FILES,FLDS,RECS,XFILE,XREC,XFLD,HOLD,FLD,TOTAL

 +2        NEW COUNT,COUNT2,XTEMP,XTFILE,TMP,TMP1,TMP2

           SET ERROR=""

 +3        SET FILE=$$RTNFILE(FILE,FIELDS)

           IF $EXTRACT(FILE,1)=" "

               QUIT FILE

 +4        FOR TOTAL=1:1:255

               SET XFILE=$PIECE(FILE,U,TOTAL)

               SET XREC=$PIECE(REC,U,TOTAL)

               SET XFLD=$PIECE(FIELDS,U,TOTAL)

               IF (XREC_XFLD)=""

                   QUIT 

               SET TEMP(TOTAL)=XFILE_U_XREC_U_XFLD

 +5        SET TOTAL=TOTAL-1

 +6        FOR COUNT=1:1:TOTAL

               IF ERROR'=""

                   QUIT 

               Begin DoDot:1

 +7                SET XTEMP=TEMP(COUNT)

                   IF COUNT>1

                       SET BACK=TEMP(COUNT-1)

 +8                SET XFILE=+$PIECE(XTEMP,U)

                   SET XREC=+$PIECE(XTEMP,U,2)

                   SET XFLD=$PIECE(XTEMP,U,3)

 +9                IF XFILE<1

                       SET ERROR=" 2.1 - (Sub)File is less than 1 or null"

                       QUIT 

 +10               IF XREC<1

                       SET ERROR=" 2.2 - (Sub)Record is less than 1 or null"

                       QUIT 

 +11               IF '$DATA(^DD(XFILE))

                       SET ERROR=" 2.3 - (Sub)File is not define"

                       QUIT 

 +12               IF COUNT>1

                       SET HOLD=+$PIECE($GET(^DD(+$PIECE(BACK,U,1),+$PIECE(BACK,U,3),0)),U,2)

                       IF XFILE'=HOLD

                           SET ERROR=" 2.4 - Subfile missing in Data Dictionary"

                           QUIT 

 +13               FOR COUNT2=1:1:255

                       SET FLD=$PIECE(XFLD,";",COUNT2)

                       IF FLD=""!(ERROR'="")

                           QUIT 

                       Begin DoDot:2

 +14                       IF +FLD=0

                               SET ERROR=" 2.5 - (Sub)Field is zero or null"

 +15                       IF '$DATA(^DD(XFILE,FLD))

                               SET ERROR=" 2.6 - (Sub)Field is not defined in DD"

 +16                       IF COUNT=TOTAL

                               SET TEMP("FLD",FLD)=$PIECE(DATA,"|",COUNT2)

                               SET TEMP("TYP",FLD)=$PIECE(TYPE,U,COUNT2)

                               SET TEMP("FLDNAME",FLD)=$PIECE(^DD(XFILE,FLD,0),U,1)

 +17                       SET (TEMP("EXC",FLD),X)=$GET(EXC(FLD))

 +18                       IF X

                               DO ^DIM

                           IF '$DATA(X)

                               SET ERROR=" 2.7 Syntax error in the Execption Code"

                       End DoDot:2

               End DoDot:1

 +19       SET TEMP("X")=$PIECE(TEMP(TOTAL),U,3)

 +20       SET TEMP("XF")=$PIECE(TEMP(TOTAL),U,1)

 +21       SET TEMP("USER")=+$GET(USER)

 +22       SET TEMP("DIC")=$$RTNDIE(.TEMP)

 +23       SET BACK=$LENGTH(TEMP("DIC"))

 +24       SET HOLD=$EXTRACT(TEMP("DIC"),1,BACK-1)

 +25       SET TEMP("GLO")=HOLD_$SELECT($EXTRACT(TEMP("DIC"),BACK)=",":")",1:"")

 +26       IF $EXTRACT(TEMP("DIC"),1)=" "

               SET ERROR=TEMP("DIC")

 +27       QUIT 

RTNFILE(FILE,FIELDS) ;Get the Subfile -This is used og RTELM-

 +1        NEW XCOUNT,XFILE,ERROR,XTMP,XFLD,XSFILE,XFLDN,XTFILE,XTMP2

 +2        SET (XSFILE,XTFILE)=+FILE

           SET ERROR=""

 +3        FOR XCOUNT=1:1:255

               SET XFLD=$PIECE(FIELDS,U,XCOUNT)

               SET XTMP2=$PIECE(FIELDS,U,XCOUNT+1)

               IF XTMP2=""!(ERROR'="")

                   QUIT 

               Begin DoDot:1

 +4                SET XTMP=$GET(^DD(XTFILE,+XFLD,0))

                   IF XTMP=""

                       SET ERORR=" Field not in DD"

                       QUIT 

 +5                SET XTFILE=+$PIECE(XTMP,U,2)

                   IF '$DATA(^DD(XTFILE))

                       SET ERROR=" Undefine (Sub)file"

 +6                SET XSFILE=XSFILE_U_XTFILE

               End DoDot:1

 +7        QUIT $SELECT(ERROR="":XSFILE,1:ERROR)

RTNDIE(TEMP) ;Return the DIE value

 +1        NEW XFILE,XLOOP,XNODE,XBACK,ERROR

           SET ERROR=""

 +2        IF '$DATA(TEMP)

               QUIT " 0.0 - Require array not define"

 +3        SET XFILE=$GET(^DIC($PIECE(+$GET(TEMP(1)),U,1),0,"GL"))

           SET XLOOP=1

 +4        IF XFILE=""

               QUIT " 3.1 - Global location is not defined"

 +5        FOR 

               SET XLOOP=+$ORDER(TEMP(XLOOP))

               IF XLOOP=0!(ERROR'="")

                   QUIT 

               Begin DoDot:1

 +6                SET XBACK=TEMP(XLOOP-1)

                   SET XFILE=XFILE_$PIECE(XBACK,U,2)_","

 +7                SET XNODE=$GET(^DD(+$PIECE(XBACK,U,1),+$PIECE(XBACK,U,3),0))

 +8                SET XNODE=$PIECE($PIECE(XNODE,U,4),";",1)

 +9                IF XNODE=""

                       SET ERROR=" 3.2 - The zero node of the DD is undefined"

                       QUIT 

 +10      ; DAD 8-5-96

                   IF XNODE'=+XNODE

                       SET XNODE=""""_XNODE_""""

 +11               SET XFILE=XFILE_XNODE_","

               End DoDot:1

 +12       IF ERROR=""

               SET ERROR=$$CHKFILE(XFILE)

 +13       QUIT $SELECT(ERROR="":XFILE,1:ERROR)

RTNDR(TEMP,TYPE) ;Return The DR value

 +1        NEW XTYPE,XERROR,XFLD,XDR,XHLD,XDAT

 +2        SET TYPE=+$GET(TYPE)

 +3        IF '$DATA(TEMP)

               QUIT " 0.0 - Require array not define"

 +4        SET XTYPE="///"

           SET (XERROR,XFLD,XDR)=""

 +5        FOR 

               SET XFLD=+$ORDER(TEMP("FLD",XFLD))

               IF XFLD=0

                   QUIT 

               Begin DoDot:1

 +6                IF (TYPE=1)

                       IF ($GET(TEMP("EXC",XHOLD))'="")

                           IF (ERROR'="")

                               Begin DoDot:2

 +7                                SET X=TEMP("FLD",FLD)

                                   IF X'=""

                                       XECUTE TEMP("EXC",XHOLD)

 +8                                IF X'=""

                                       SET TEMP("FLD",FLD)=X

                               End DoDot:2

 +9                SET XHLD=$GET(TEMP("TYP",XFLD))

                   SET XHLD=$SELECT(XHLD="":XTYPE,1:XHLD)

 +10               SET XDAT=$GET(TEMP("FLD",XFLD))

                   SET XDR=XDR_$SELECT(XDR="":"",1:";")

 +11               IF TYPE=1

                       SET XDR=XDR_XFLD_$SELECT(XDAT="":XTYPE,1:XHLD)_XDAT

 +12               IF TYPE=0

                       SET XDR=XDR_XFLD

               End DoDot:1

 +13       QUIT XDR

RTNDA(TEMP,ARRAY,ERROR) ;Return The DA value

 +1        NEW HOLD,TOTAL,COUNT

           SET ERROR=""

           SET TOTAL=$$TOTAL(.TEMP)

 +2        IF '$DATA(TEMP)

               QUIT " 0.0 - Require array not define"

 +3        FOR COUNT=TOTAL:-1:1

               IF ERROR'=""

                   QUIT 

               Begin DoDot:1

 +4                SET ARRAY(TOTAL-COUNT)=+$PIECE($GET(TEMP(COUNT)),U,2)

 +5                IF ARRAY(TOTAL-COUNT)<1

                       SET ERROR=" 5.1 - Record is less than 1 or null"

               End DoDot:1

 +6        SET ARRAY=ARRAY(0)

           KILL ARRAY(0)

 +7        QUIT 

STR(XTEMP) ;GET THE DATA VALUE (used by RTNELM)

 +1        NEW TEMP,LOOP,HOLD

 +2        SET TEMP=$PIECE(XTEMP,"/",2,255)

           FOR LOOP=1:1:4

               IF $EXTRACT(TEMP,LOOP)'="/"

                   QUIT 

 +3        SET HOLD=$EXTRACT(TEMP,LOOP,$LENGTH(TEMP))

 +4        QUIT $SELECT(HOLD="@":"",1:HOLD)

TOTAL(ARRAY) ;Find the total count in an array used by calls)

 +1        NEW COUNT,TOTAL

           SET (COUNT,TOTAL)=0

 +2        FOR 

               SET COUNT=+$ORDER(TEMP(COUNT))

               IF COUNT'=0

                   SET TOTAL=COUNT

               IF COUNT=0

                   QUIT 

 +3        QUIT TOTAL

CHKFILE(FILE) ;This validates if global reference is a fileMan file & exists

 +1        NEW X

           SET ERROR=""

 +2        SET X="S:'$D("_FILE_"0)) ERROR="" 6.1 (sub)file does not exist"""

 +3        DO ^DIM

 +4        IF '$DATA(X)!($EXTRACT(FILE,1)'["^")!(($EXTRACT(FILE,$LENGTH(FILE))'[",")&($EXTRACT(FILE,$LENGTH(FILE))'["("))

               SET ERROR=" 7.1 Bad Global name for FileMan"

 +5        QUIT ERROR