- 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 Feb 18, 2025@23:42:21 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)
