source: FOIAVistA/trunk/r/MEDICINE-MC/MCDBELM.m@ 1757

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 4.2 KB
Line 
1MCDBELM ;WISC/DCB-save and load util. ;8/15/96 09:52
2 ;;2.3;Medicine;;09/13/1996
3 Q
4RTNELM(FILE,REC,FIELDS,EXC,DATA,TYPE,USER,TEMP,ERROR) ;RTN the elements in an array
5 N Y,X,BACK,FILES,FLDS,RECS,XFILE,XREC,XFLD,HOLD,FLD,TOTAL
6 N COUNT,COUNT2,XTEMP,XTFILE,TMP,TMP1,TMP2 S ERROR=""
7 S FILE=$$RTNFILE(FILE,FIELDS) Q:$E(FILE,1)=" " FILE
8 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
9 S TOTAL=TOTAL-1
10 F COUNT=1:1:TOTAL Q:ERROR'="" D
11 .S XTEMP=TEMP(COUNT) S:COUNT>1 BACK=TEMP(COUNT-1)
12 .S XFILE=+$P(XTEMP,U),XREC=+$P(XTEMP,U,2),XFLD=$P(XTEMP,U,3)
13 .I XFILE<1 S ERROR=" 2.1 - (Sub)File is less than 1 or null" Q
14 .I XREC<1 S ERROR=" 2.2 - (Sub)Record is less than 1 or null" Q
15 .I '$D(^DD(XFILE)) S ERROR=" 2.3 - (Sub)File is not define" Q
16 .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
17 .F COUNT2=1:1:255 S FLD=$P(XFLD,";",COUNT2) Q:FLD=""!(ERROR'="") D
18 ..I +FLD=0 S ERROR=" 2.5 - (Sub)Field is zero or null"
19 ..S:'$D(^DD(XFILE,FLD)) ERROR=" 2.6 - (Sub)Field is not defined in DD"
20 ..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)
21 ..S (TEMP("EXC",FLD),X)=$G(EXC(FLD))
22 ..D:X ^DIM S:'$D(X) ERROR=" 2.7 Syntax error in the Execption Code"
23 S TEMP("X")=$P(TEMP(TOTAL),U,3)
24 S TEMP("XF")=$P(TEMP(TOTAL),U,1)
25 S TEMP("USER")=+$G(USER)
26 S TEMP("DIC")=$$RTNDIE(.TEMP)
27 S BACK=$L(TEMP("DIC"))
28 S HOLD=$E(TEMP("DIC"),1,BACK-1)
29 S TEMP("GLO")=HOLD_$S($E(TEMP("DIC"),BACK)=",":")",1:"")
30 S:$E(TEMP("DIC"),1)=" " ERROR=TEMP("DIC")
31 Q
32RTNFILE(FILE,FIELDS) ;Get the Subfile -This is used og RTELM-
33 N XCOUNT,XFILE,ERROR,XTMP,XFLD,XSFILE,XFLDN,XTFILE,XTMP2
34 S (XSFILE,XTFILE)=+FILE,ERROR=""
35 F XCOUNT=1:1:255 S XFLD=$P(FIELDS,U,XCOUNT),XTMP2=$P(FIELDS,U,XCOUNT+1) Q:XTMP2=""!(ERROR'="") D
36 .S XTMP=$G(^DD(XTFILE,+XFLD,0)) I XTMP="" S ERORR=" Field not in DD" Q
37 .S XTFILE=+$P(XTMP,U,2) I '$D(^DD(XTFILE)) S ERROR=" Undefine (Sub)file"
38 .S XSFILE=XSFILE_U_XTFILE
39 Q $S(ERROR="":XSFILE,1:ERROR)
40RTNDIE(TEMP) ;Return the DIE value
41 N XFILE,XLOOP,XNODE,XBACK,ERROR S ERROR=""
42 I '$D(TEMP) Q " 0.0 - Require array not define"
43 S XFILE=$G(^DIC($P(+$G(TEMP(1)),U,1),0,"GL")),XLOOP=1
44 Q:XFILE="" " 3.1 - Global location is not defined"
45 F S XLOOP=+$O(TEMP(XLOOP)) Q:XLOOP=0!(ERROR'="") D
46 .S XBACK=TEMP(XLOOP-1),XFILE=XFILE_$P(XBACK,U,2)_","
47 .S XNODE=$G(^DD(+$P(XBACK,U,1),+$P(XBACK,U,3),0))
48 .S XNODE=$P($P(XNODE,U,4),";",1)
49 .I XNODE="" S ERROR=" 3.2 - The zero node of the DD is undefined" Q
50 .I XNODE'=+XNODE S XNODE=""""_XNODE_"""" ; DAD 8-5-96
51 .S XFILE=XFILE_XNODE_","
52 S:ERROR="" ERROR=$$CHKFILE(XFILE)
53 Q $S(ERROR="":XFILE,1:ERROR)
54RTNDR(TEMP,TYPE) ;Return The DR value
55 N XTYPE,XERROR,XFLD,XDR,XHLD,XDAT
56 S TYPE=+$G(TYPE)
57 I '$D(TEMP) Q " 0.0 - Require array not define"
58 S XTYPE="///",(XERROR,XFLD,XDR)=""
59 F S XFLD=+$O(TEMP("FLD",XFLD)) Q:XFLD=0 D
60 .I (TYPE=1),($G(TEMP("EXC",XHOLD))'=""),(ERROR'="") D
61 ..S X=TEMP("FLD",FLD) X:X'="" TEMP("EXC",XHOLD)
62 ..S:X'="" TEMP("FLD",FLD)=X
63 .S XHLD=$G(TEMP("TYP",XFLD)),XHLD=$S(XHLD="":XTYPE,1:XHLD)
64 .S XDAT=$G(TEMP("FLD",XFLD)),XDR=XDR_$S(XDR="":"",1:";")
65 .S:TYPE=1 XDR=XDR_XFLD_$S(XDAT="":XTYPE,1:XHLD)_XDAT
66 .S:TYPE=0 XDR=XDR_XFLD
67 Q XDR
68RTNDA(TEMP,ARRAY,ERROR) ;Return The DA value
69 N HOLD,TOTAL,COUNT S ERROR="",TOTAL=$$TOTAL(.TEMP)
70 I '$D(TEMP) Q " 0.0 - Require array not define"
71 F COUNT=TOTAL:-1:1 Q:ERROR'="" D
72 .S ARRAY(TOTAL-COUNT)=+$P($G(TEMP(COUNT)),U,2)
73 .S:ARRAY(TOTAL-COUNT)<1 ERROR=" 5.1 - Record is less than 1 or null"
74 S ARRAY=ARRAY(0) K ARRAY(0)
75 Q
76STR(XTEMP) ;GET THE DATA VALUE (used by RTNELM)
77 N TEMP,LOOP,HOLD
78 S TEMP=$P(XTEMP,"/",2,255) F LOOP=1:1:4 Q:$E(TEMP,LOOP)'="/"
79 S HOLD=$E(TEMP,LOOP,$L(TEMP))
80 Q $S(HOLD="@":"",1:HOLD)
81TOTAL(ARRAY) ;Find the total count in an array used by calls)
82 N COUNT,TOTAL S (COUNT,TOTAL)=0
83 F S COUNT=+$O(TEMP(COUNT)) S:COUNT'=0 TOTAL=COUNT Q:COUNT=0
84 Q TOTAL
85CHKFILE(FILE) ;This validates if global reference is a fileMan file & exists
86 N X S ERROR=""
87 S X="S:'$D("_FILE_"0)) ERROR="" 6.1 (sub)file does not exist"""
88 D ^DIM
89 I '$D(X)!($E(FILE,1)'["^")!(($E(FILE,$L(FILE))'[",")&($E(FILE,$L(FILE))'["(")) S ERROR=" 7.1 Bad Global name for FileMan"
90 Q ERROR
Note: See TracBrowser for help on using the repository browser.