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)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCORMN1 3965 printed Dec 13, 2024@02:15:54 Page 2
MCORMN1 ;WISC/DCB-BUILD INTERMEDIATE DATA SET ;4/16/97 15:21
+1 ;;2.3;Medicine;**4**;09/13/1996
GETDATA(MCPROC,MCENT,MCDEST,MCFILE,TYPE) ;function to get data defined by data set MCDSNAM
+1 NEW MCA,MCB,MCDA,MCDA,MCDIC,MCDIQ,MCDR,MCDSIX,MCROOT,MCTEMP,MCDRDR
+2 NEW MCDSR,MCERR,MCFIL,MCFTMP,MCL2,MCL3,MCMU,MCMM,MCDSIX,MCDSR
+3 NEW MCROOT,MCSF,MCSFIND,MCSFLD,MCSFREC,MCSUBFA,MCTMP,MCTMP1
+4 NEW MCFLDIX,MCFLDNO,MCFLDNO,MCFLDREC,MCFLDUSE,MCSUBFNU,MCFIL,MCDD
+5 NEW MCSBFILE,MCSREC,MCREC,MCFLD,MCTYPE,MCDSIX1,MCGPROC,MCGFILE,MCPATFLD
+6 SET MCTYPE=$SELECT(TYPE="RD":"F",1:"B")
+7 IF '$DATA(MCDEST)
SET MCDEST="^TMP(""MC"",$J)"
+8 NEW MCDSIX,MCDSOK
+9 SET MCGPROC=$ORDER(^MCAR(697.2,"B",MCPROC,""))
SET MCPATFLD=$PIECE($GET(^MCAR(697.2,MCGPROC,0)),U,12)
SET (MCDSIX1,MCDSIX)=0
+10 FOR
SET MCDSIX1=+$ORDER(^MCAR(690.2,"D",MCGPROC,MCDSIX1))
if MCDSIX1=0!(MCDSIX'=0)
QUIT
Begin DoDot:1
+11 if '$DATA(^MCAR(690.2,MCDSIX1,0))
QUIT
+12 if $PIECE(^MCAR(690.2,MCDSIX1,0),U,3)=MCTYPE
SET MCDSIX=MCDSIX1
End DoDot:1
+13 if MCDSIX=0
QUIT 0
+14 SET MCDSR=^MCAR(690.2,MCDSIX,0)
SET MCGFILE=$PIECE(MCDSR,U,2)
TTT SET MCROOT=^DIC(MCGFILE,0,"GL")
+1 IF $$MEDID(MCGFILE,MCENT,PATID,MCPATFLD)=0
WRITE !,"File/Patient ID mismatch"
QUIT 0
+2 DO GETITEM
QUIT 1
+3 ;
GETITEM ; subroutine to get data defined in data set index MCDSIX for file entry MCENT
+1 ; sort out the single and multiple fields
DO SORTFLDS
+2 ; process the multiple fields
DO MULTI
+3 QUIT
SORTFLDS ; sort out the single and multiple fields
+1 ;S MCFLD="",MCDR=""
+2 KILL MCDRDR
SET MCFLD=""
SET MCDRDR=0
+3 FOR
SET MCFLD=$ORDER(^MCAR(690.2,MCDSIX,1,"B",MCFLD))
if MCFLD=""
QUIT
DO SORT1
+4 ;S MCDIC=MCGFILE,MCDA=MCENT,MCDIQ=MCDEST,MCDIQ(0)="EF"
+5 SET MCDIC=MCGFILE
SET MCDA=MCENT
SET MCDIQ(0)="EF"
+6 IF $EXTRACT(MCDEST,$LENGTH(MCDEST))=")"
SET MCDIQ=$EXTRACT(MCDEST,1,$LENGTH(MCDEST)-1)_","
+7 IF '$TEST
SET MCDIQ=MCDEST
+8 DO ^MCORMN2
+9 QUIT
SORT1 ;
+1 SET MCFLDIX=+$ORDER(^MCAR(690.2,MCDSIX,1,"B",MCFLD,""))
if MCFLDIX=0
QUIT
+2 SET MCFLDREC=$GET(^MCAR(690.2,MCDSIX,1,MCFLDIX,0))
if MCFLDREC=""
QUIT
+3 SET MCFLDNO=$PIECE(MCFLDREC,"^",1)
SET MCFLDUSE=$PIECE(MCFLDREC,"^",2)
+4 SET MCTMP=^DD(MCGFILE,MCFLDNO,0)
+5 ;I $L(MCDR)<200 S MCDR=MCDR_MCFLD_";" ;TEMP FIX
+6 ;REAL FIX
SET MCDRDR=MCDRDR+1
SET MCDRDR(MCDRDR)=MCFLD
+7 SET @MCDEST@("F",MCGFILE,MCFLDNO,0)=$PIECE(MCTMP,U,1,2)_U_MCFLDUSE
+8 SET @MCDEST@("F",MCGFILE,MCFLDNO,1)=$PIECE(MCFLDREC,U,3,255)
+9 QUIT
MULTI ; Get the Sub-file data
+1 SET MCSBFILE=""
KILL MCDRDR
+2 FOR
SET MCSBFILE=$ORDER(^MCAR(690.2,MCDSIX,2,"B",MCSBFILE))
if MCSBFILE=""
QUIT
DO MULTIF
+3 QUIT
MULTIF ; Get the fields they need
+1 SET MCREC=$ORDER(^MCAR(690.2,MCDSIX,2,"B",MCSBFILE,""))
if MCREC=""
QUIT
+2 if '$DATA(^MCAR(690.2,MCDSIX,2,MCREC,0))
QUIT
+3 SET MCSUBFNU=^MCAR(690.2,MCDSIX,2,MCREC,0)
SET MCSFLD=""
+4 KILL MCSUBFA,MCSFREC
+5 SET MCDR(MCSBFILE)=""
+6 FOR
SET MCSFLD=$ORDER(^MCAR(690.2,MCDSIX,2,MCREC,1,"B",MCSFLD))
if MCSFLD=""
QUIT
DO SUBFLD
+7 SET MCDR=$ORDER(^DD(MCFILE,"SB",MCSUBFNU,""))
IF MCDR=""
QUIT
+8 SET MCDRDR(1)=MCDR
+9 ;S MCTMP=$P($G(^DD(MCGFILE,MCDR,0)),U,4) Q:MCTMP=""
+10 SET MCTMP=$$GET1^DID(MCGFILE,MCDR,"","GLOBAL SUBSCRIPT LOCATION")
if MCTMP=""
QUIT
+11 SET MCA=$PIECE(MCTMP,";",1)
SET MCB=$PIECE(MCTMP,";",2)
SET MCDIQ(0)="EF"
SET MCFTMP=MCFILE
+12 SET MCDIQ(0)="EF"
SET MCSFIND=0
+13 FOR
SET MCSFIND=$ORDER(^MCAR(MCGFILE,MCENT,MCA,MCSFIND))
if +MCSFIND=0
QUIT
DO HITIT
+14 QUIT
SUBFLD ; Build the fields
+1 SET MCSREC=$ORDER(^MCAR(690.2,MCDSIX,2,MCREC,1,"B",MCSFLD,""))
if MCSREC=""
QUIT
+2 SET MCTMP=$GET(^MCAR(690.2,MCDSIX,2,MCREC,1,MCSREC,0))
SET MCD1=MCSREC
+3 SET MCDD=$GET(^DD(MCSBFILE,MCSFLD,0))
if MCDD=""
QUIT
+4 SET MCDR(MCSBFILE)=MCDR(MCSBFILE)_MCSFLD_";"
+5 DO SETNODE
+6 QUIT
HITIT ; Get the data that are out there FROM MULTI.
+1 SET MCDA(MCSUBFNU)=MCSFIND
+2 DO ^MCORMN3
+3 QUIT
SETNODE ;
+1 SET TEMP=$PIECE(MCDD,U,1,2)_U_$PIECE(MCTMP,U,2,3)
+2 SET @MCDEST@("F",MCSBFILE,MCSFLD,0)=TEMP
+3 SET @MCDEST@("F",MCSBFILE,MCSFLD,1)=$PIECE(MCTMP,U,3,255)
+4 QUIT
MEDID(MCGFILE,MCENT,PATID,MCPATFLD) ;
+1 NEW IEN,FILE,NODE,PIECE
+2 SET IEN=$SELECT(+MCPATFLD>0:MCPATFLD,1:1)
+3 ;S NODE=$P($P(^DD(MCGFILE,IEN,0),U,4),";"),PIECE=+$P(^(0),";",2)
+4 SET NODE=$PIECE($$GET1^DID(MCGFILE,IEN,"","GLOBAL SUBSCRIPT LOCATION"),";")
SET PIECE=+$PIECE($$GET1^DID(MCGFILE,IEN,"","GLOBAL SUBSCRIPT LOCATION"),";",2)
+5 ;W !," NODE ",NODE," PIECE ",PIECE,!
+6 ;W !," test ",+$P($G(^MCAR(MCGFILE,MCENT,NODE)),U,PIECE)
+7 QUIT $SELECT(IEN="":0,PATID=+$PIECE($GET(^MCAR(MCGFILE,MCENT,NODE)),U,PIECE):1,1:0)
