source: FOIAVistA/trunk/r/MEDICINE-MC/MCORMN1.m@ 1528

MCORMN1 ;WISC/DCB-BUILD INTERMEDIATE DATA SET ;4/16/97  15:21
 ;;2.3;Medicine;**4**;09/13/1996
GETDATA(MCPROC,MCENT,MCDEST,MCFILE,TYPE) ;function to get data defined by data set MCDSNAM
 N MCA,MCB,MCDA,MCDA,MCDIC,MCDIQ,MCDR,MCDSIX,MCROOT,MCTEMP,MCDRDR
 N MCDSR,MCERR,MCFIL,MCFTMP,MCL2,MCL3,MCMU,MCMM,MCDSIX,MCDSR
 N MCROOT,MCSF,MCSFIND,MCSFLD,MCSFREC,MCSUBFA,MCTMP,MCTMP1
 N MCFLDIX,MCFLDNO,MCFLDNO,MCFLDREC,MCFLDUSE,MCSUBFNU,MCFIL,MCDD
 N MCSBFILE,MCSREC,MCREC,MCFLD,MCTYPE,MCDSIX1,MCGPROC,MCGFILE,MCPATFLD
 S MCTYPE=$S(TYPE="RD":"F",1:"B")
 I '$D(MCDEST) S MCDEST="^TMP(""MC"",$J)"
 N MCDSIX,MCDSOK
 S MCGPROC=$O(^MCAR(697.2,"B",MCPROC,"")),MCPATFLD=$P($G(^MCAR(697.2,MCGPROC,0)),U,12),(MCDSIX1,MCDSIX)=0
 F  S MCDSIX1=+$O(^MCAR(690.2,"D",MCGPROC,MCDSIX1)) Q:MCDSIX1=0!(MCDSIX'=0)  D
 .Q:'$D(^MCAR(690.2,MCDSIX1,0))
 .S:$P(^MCAR(690.2,MCDSIX1,0),U,3)=MCTYPE MCDSIX=MCDSIX1
 Q:MCDSIX=0 0
 S MCDSR=^MCAR(690.2,MCDSIX,0),MCGFILE=$P(MCDSR,U,2)
TTT S MCROOT=^DIC(MCGFILE,0,"GL")
 I $$MEDID(MCGFILE,MCENT,PATID,MCPATFLD)=0 W !,"File/Patient ID mismatch" Q 0
 D GETITEM Q 1
 ;
GETITEM ;    subroutine to get data defined in data set index MCDSIX for file entry MCENT
 D SORTFLDS ;    sort out the single and multiple fields
 D MULTI ;    process the multiple fields
 Q
SORTFLDS ;    sort out the single and multiple fields
 ;S MCFLD="",MCDR=""
 K MCDRDR S MCFLD="",MCDRDR=0
 F  S MCFLD=$O(^MCAR(690.2,MCDSIX,1,"B",MCFLD)) Q:MCFLD=""  D SORT1
 ;S MCDIC=MCGFILE,MCDA=MCENT,MCDIQ=MCDEST,MCDIQ(0)="EF"
 S MCDIC=MCGFILE,MCDA=MCENT,MCDIQ(0)="EF"
 I $E(MCDEST,$L(MCDEST))=")" S MCDIQ=$E(MCDEST,1,$L(MCDEST)-1)_","
 E  S MCDIQ=MCDEST
 D ^MCORMN2
 Q
SORT1 ;
 S MCFLDIX=+$O(^MCAR(690.2,MCDSIX,1,"B",MCFLD,"")) Q:MCFLDIX=0
 S MCFLDREC=$G(^MCAR(690.2,MCDSIX,1,MCFLDIX,0)) Q:MCFLDREC="" 
 S MCFLDNO=$P(MCFLDREC,"^",1),MCFLDUSE=$P(MCFLDREC,"^",2)
 S MCTMP=^DD(MCGFILE,MCFLDNO,0)
 ;I $L(MCDR)<200 S MCDR=MCDR_MCFLD_";"  ;TEMP FIX
 S MCDRDR=MCDRDR+1,MCDRDR(MCDRDR)=MCFLD ;REAL FIX
 S @MCDEST@("F",MCGFILE,MCFLDNO,0)=$P(MCTMP,U,1,2)_U_MCFLDUSE
 S @MCDEST@("F",MCGFILE,MCFLDNO,1)=$P(MCFLDREC,U,3,255)
 Q
MULTI ; Get the Sub-file data 
 S MCSBFILE="" K MCDRDR
 F  S MCSBFILE=$O(^MCAR(690.2,MCDSIX,2,"B",MCSBFILE)) Q:MCSBFILE=""  D MULTIF
 Q
MULTIF ; Get the fields they need
 S MCREC=$O(^MCAR(690.2,MCDSIX,2,"B",MCSBFILE,"")) Q:MCREC=""
 Q:'$D(^MCAR(690.2,MCDSIX,2,MCREC,0))
 S MCSUBFNU=^MCAR(690.2,MCDSIX,2,MCREC,0),MCSFLD=""
 K MCSUBFA,MCSFREC
 S MCDR(MCSBFILE)=""
 F  S MCSFLD=$O(^MCAR(690.2,MCDSIX,2,MCREC,1,"B",MCSFLD)) Q:MCSFLD=""  D SUBFLD
 S MCDR=$O(^DD(MCFILE,"SB",MCSUBFNU,"")) I MCDR="" Q
 S MCDRDR(1)=MCDR
 ;S MCTMP=$P($G(^DD(MCGFILE,MCDR,0)),U,4) Q:MCTMP=""
 S MCTMP=$$GET1^DID(MCGFILE,MCDR,"","GLOBAL SUBSCRIPT LOCATION") Q:MCTMP=""
 S MCA=$P(MCTMP,";",1),MCB=$P(MCTMP,";",2),MCDIQ(0)="EF",MCFTMP=MCFILE
 S MCDIQ(0)="EF",MCSFIND=0
 F  S MCSFIND=$O(^MCAR(MCGFILE,MCENT,MCA,MCSFIND)) Q:+MCSFIND=0  D HITIT
 Q
SUBFLD ; Build the fields
 S MCSREC=$O(^MCAR(690.2,MCDSIX,2,MCREC,1,"B",MCSFLD,"")) Q:MCSREC=""
 S MCTMP=$G(^MCAR(690.2,MCDSIX,2,MCREC,1,MCSREC,0)),MCD1=MCSREC
 S MCDD=$G(^DD(MCSBFILE,MCSFLD,0)) Q:MCDD=""
 S MCDR(MCSBFILE)=MCDR(MCSBFILE)_MCSFLD_";"
 D SETNODE
 Q
HITIT ; Get the data that are out there FROM MULTI.
 S MCDA(MCSUBFNU)=MCSFIND
 D ^MCORMN3
 Q
SETNODE ;
 S TEMP=$P(MCDD,U,1,2)_U_$P(MCTMP,U,2,3)
 S @MCDEST@("F",MCSBFILE,MCSFLD,0)=TEMP
 S @MCDEST@("F",MCSBFILE,MCSFLD,1)=$P(MCTMP,U,3,255)
 Q
MEDID(MCGFILE,MCENT,PATID,MCPATFLD) ;
 N IEN,FILE,NODE,PIECE
 S IEN=$S(+MCPATFLD>0:MCPATFLD,1:1)
 ;S NODE=$P($P(^DD(MCGFILE,IEN,0),U,4),";"),PIECE=+$P(^(0),";",2)
 S NODE=$P($$GET1^DID(MCGFILE,IEN,"","GLOBAL SUBSCRIPT LOCATION"),";"),PIECE=+$P($$GET1^DID(MCGFILE,IEN,"","GLOBAL SUBSCRIPT LOCATION"),";",2)
 ;W !,"  NODE  ",NODE,"  PIECE  ",PIECE,!
 ;W !," test ",+$P($G(^MCAR(MCGFILE,MCENT,NODE)),U,PIECE)
 Q $S(IEN="":0,PATID=+$P($G(^MCAR(MCGFILE,MCENT,NODE)),U,PIECE):1,1:0)