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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCDBELM 4418 printed Apr 09, 2024@21:17:59 Page 2
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
