source: FOIAVistA/trunk/r/MEDICINE-MC/MCORMN1.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: 3.8 KB
Line 
1MCORMN1 ;WISC/DCB-BUILD INTERMEDIATE DATA SET ;4/16/97 15:21
2 ;;2.3;Medicine;**4**;09/13/1996
3GETDATA(MCPROC,MCENT,MCDEST,MCFILE,TYPE) ;function to get data defined by data set MCDSNAM
4 N MCA,MCB,MCDA,MCDA,MCDIC,MCDIQ,MCDR,MCDSIX,MCROOT,MCTEMP,MCDRDR
5 N MCDSR,MCERR,MCFIL,MCFTMP,MCL2,MCL3,MCMU,MCMM,MCDSIX,MCDSR
6 N MCROOT,MCSF,MCSFIND,MCSFLD,MCSFREC,MCSUBFA,MCTMP,MCTMP1
7 N MCFLDIX,MCFLDNO,MCFLDNO,MCFLDREC,MCFLDUSE,MCSUBFNU,MCFIL,MCDD
8 N MCSBFILE,MCSREC,MCREC,MCFLD,MCTYPE,MCDSIX1,MCGPROC,MCGFILE,MCPATFLD
9 S MCTYPE=$S(TYPE="RD":"F",1:"B")
10 I '$D(MCDEST) S MCDEST="^TMP(""MC"",$J)"
11 N MCDSIX,MCDSOK
12 S MCGPROC=$O(^MCAR(697.2,"B",MCPROC,"")),MCPATFLD=$P($G(^MCAR(697.2,MCGPROC,0)),U,12),(MCDSIX1,MCDSIX)=0
13 F S MCDSIX1=+$O(^MCAR(690.2,"D",MCGPROC,MCDSIX1)) Q:MCDSIX1=0!(MCDSIX'=0) D
14 .Q:'$D(^MCAR(690.2,MCDSIX1,0))
15 .S:$P(^MCAR(690.2,MCDSIX1,0),U,3)=MCTYPE MCDSIX=MCDSIX1
16 Q:MCDSIX=0 0
17 S MCDSR=^MCAR(690.2,MCDSIX,0),MCGFILE=$P(MCDSR,U,2)
18TTT S MCROOT=^DIC(MCGFILE,0,"GL")
19 I $$MEDID(MCGFILE,MCENT,PATID,MCPATFLD)=0 W !,"File/Patient ID mismatch" Q 0
20 D GETITEM Q 1
21 ;
22GETITEM ; subroutine to get data defined in data set index MCDSIX for file entry MCENT
23 D SORTFLDS ; sort out the single and multiple fields
24 D MULTI ; process the multiple fields
25 Q
26SORTFLDS ; sort out the single and multiple fields
27 ;S MCFLD="",MCDR=""
28 K MCDRDR S MCFLD="",MCDRDR=0
29 F S MCFLD=$O(^MCAR(690.2,MCDSIX,1,"B",MCFLD)) Q:MCFLD="" D SORT1
30 ;S MCDIC=MCGFILE,MCDA=MCENT,MCDIQ=MCDEST,MCDIQ(0)="EF"
31 S MCDIC=MCGFILE,MCDA=MCENT,MCDIQ(0)="EF"
32 I $E(MCDEST,$L(MCDEST))=")" S MCDIQ=$E(MCDEST,1,$L(MCDEST)-1)_","
33 E S MCDIQ=MCDEST
34 D ^MCORMN2
35 Q
36SORT1 ;
37 S MCFLDIX=+$O(^MCAR(690.2,MCDSIX,1,"B",MCFLD,"")) Q:MCFLDIX=0
38 S MCFLDREC=$G(^MCAR(690.2,MCDSIX,1,MCFLDIX,0)) Q:MCFLDREC=""
39 S MCFLDNO=$P(MCFLDREC,"^",1),MCFLDUSE=$P(MCFLDREC,"^",2)
40 S MCTMP=^DD(MCGFILE,MCFLDNO,0)
41 ;I $L(MCDR)<200 S MCDR=MCDR_MCFLD_";" ;TEMP FIX
42 S MCDRDR=MCDRDR+1,MCDRDR(MCDRDR)=MCFLD ;REAL FIX
43 S @MCDEST@("F",MCGFILE,MCFLDNO,0)=$P(MCTMP,U,1,2)_U_MCFLDUSE
44 S @MCDEST@("F",MCGFILE,MCFLDNO,1)=$P(MCFLDREC,U,3,255)
45 Q
46MULTI ; Get the Sub-file data
47 S MCSBFILE="" K MCDRDR
48 F S MCSBFILE=$O(^MCAR(690.2,MCDSIX,2,"B",MCSBFILE)) Q:MCSBFILE="" D MULTIF
49 Q
50MULTIF ; Get the fields they need
51 S MCREC=$O(^MCAR(690.2,MCDSIX,2,"B",MCSBFILE,"")) Q:MCREC=""
52 Q:'$D(^MCAR(690.2,MCDSIX,2,MCREC,0))
53 S MCSUBFNU=^MCAR(690.2,MCDSIX,2,MCREC,0),MCSFLD=""
54 K MCSUBFA,MCSFREC
55 S MCDR(MCSBFILE)=""
56 F S MCSFLD=$O(^MCAR(690.2,MCDSIX,2,MCREC,1,"B",MCSFLD)) Q:MCSFLD="" D SUBFLD
57 S MCDR=$O(^DD(MCFILE,"SB",MCSUBFNU,"")) I MCDR="" Q
58 S MCDRDR(1)=MCDR
59 ;S MCTMP=$P($G(^DD(MCGFILE,MCDR,0)),U,4) Q:MCTMP=""
60 S MCTMP=$$GET1^DID(MCGFILE,MCDR,"","GLOBAL SUBSCRIPT LOCATION") Q:MCTMP=""
61 S MCA=$P(MCTMP,";",1),MCB=$P(MCTMP,";",2),MCDIQ(0)="EF",MCFTMP=MCFILE
62 S MCDIQ(0)="EF",MCSFIND=0
63 F S MCSFIND=$O(^MCAR(MCGFILE,MCENT,MCA,MCSFIND)) Q:+MCSFIND=0 D HITIT
64 Q
65SUBFLD ; Build the fields
66 S MCSREC=$O(^MCAR(690.2,MCDSIX,2,MCREC,1,"B",MCSFLD,"")) Q:MCSREC=""
67 S MCTMP=$G(^MCAR(690.2,MCDSIX,2,MCREC,1,MCSREC,0)),MCD1=MCSREC
68 S MCDD=$G(^DD(MCSBFILE,MCSFLD,0)) Q:MCDD=""
69 S MCDR(MCSBFILE)=MCDR(MCSBFILE)_MCSFLD_";"
70 D SETNODE
71 Q
72HITIT ; Get the data that are out there FROM MULTI.
73 S MCDA(MCSUBFNU)=MCSFIND
74 D ^MCORMN3
75 Q
76SETNODE ;
77 S TEMP=$P(MCDD,U,1,2)_U_$P(MCTMP,U,2,3)
78 S @MCDEST@("F",MCSBFILE,MCSFLD,0)=TEMP
79 S @MCDEST@("F",MCSBFILE,MCSFLD,1)=$P(MCTMP,U,3,255)
80 Q
81MEDID(MCGFILE,MCENT,PATID,MCPATFLD) ;
82 N IEN,FILE,NODE,PIECE
83 S IEN=$S(+MCPATFLD>0:MCPATFLD,1:1)
84 ;S NODE=$P($P(^DD(MCGFILE,IEN,0),U,4),";"),PIECE=+$P(^(0),";",2)
85 S NODE=$P($$GET1^DID(MCGFILE,IEN,"","GLOBAL SUBSCRIPT LOCATION"),";"),PIECE=+$P($$GET1^DID(MCGFILE,IEN,"","GLOBAL SUBSCRIPT LOCATION"),";",2)
86 ;W !," NODE ",NODE," PIECE ",PIECE,!
87 ;W !," test ",+$P($G(^MCAR(MCGFILE,MCENT,NODE)),U,PIECE)
88 Q $S(IEN="":0,PATID=+$P($G(^MCAR(MCGFILE,MCENT,NODE)),U,PIECE):1,1:0)
Note: See TracBrowser for help on using the repository browser.