- MCORMN2 ;WISC/MLH-NON-INTERACTIVE INQUIRY ;3/18/97 13:02
- ;;2.3;Medicine;**4**;09/13/1996
- N MCDIQ0
- ;Q:'$D(MCDIC)!($D(MCDA)[0)!($D(MCDR)[0) S MCDIL=0,(MCDA(0),MCD0)=MCDA,MCDIQ0=""
- Q:'$D(MCDIC)!($D(MCDA)[0)!($O(MCDRDR(0))'>0) S MCDIL=0,(MCDA(0),MCD0)=MCDA,MCDIQ0=""
- ;I $D(MCDIQ)#2 G Q:MCDIQ["^"!($E(MCDIQ,1,2)="DI") S:MCDIQ'["(" MCDIQ=MCDIQ_"("
- S:'$D(MCDIQ(0)) MCDIQ(0)="",MCDIQ0="MCDIQ(0),"
- I $D(MCDIQ)[0 S MCDIQ="^TMP(""MC"",$J,",MCDIQ0="MCDIQ,"
- S MCDIQ0=MCDIQ0_"MCDIQ0",MCE="""E"""
- I MCDIC S MCDIC=$S($D(^DIC(MCDIC,0,"GL")):^("GL"),1:"") G:MCDIC="" Q
- LEVEL ; handle data at this level
- G Q:'$D(@(MCDIC_"0)")) S MCDI=+$P(^(0),U,2) G Q:'$D(^(MCDA,0))
- ; Note: There is no way to be sure of the value of MCDIC.
- ; We are assuming that it is ^DIC(MCDIC,0,"GL").
- ;F I=1:1 S MCDIQ1=$P(MCDR,";",I) Q:MCDIQ1="" D COLON:MCDIQ1[":",FIELD:MCDIQ1>0
- S (I,MCDRDR)=0
- F S MCDRDR=$O(MCDRDR(MCDRDR)),I=I+1 Q:MCDRDR'>0 S MCDIQ1=MCDRDR(MCDRDR) D COLON:MCDIQ1[":",FIELD:MCDIQ1>0
- Q Q:MCDIL K MCPCT,MCF,MCI,MCJ,MCX,MCY,MCC,MCDA(0),MCDRS,MCDIL,MCDI,MCDIQ1,MCE,MCD0 K:MCDIQ0]"" @MCDIQ0
- Q
- COLON ; process set of fields delimited by colon
- S MCDIQ2=$P(MCDIQ1,":",2)
- F MCDIQ1=MCDIQ1:0 D FIELD S MCDIQ1=$O(^DD(MCDI,MCDIQ1)) I MCDIQ1'>0!(MCDIQ1'<MCDIQ2) S:MCDIQ1'=MCDIQ2 MCDIQ1=0 Q
- Q
- FIELD ; process single field
- Q:'$D(^DD(MCDI,MCDIQ1,0)) S (MCF,MCY)=^(0),MCC=$P(MCF,U,4),MCX=$P(MCC,";",2),MCC=$P(MCC,";",1),MCJ=$P(MCF,U,2) G PROC:MCJ["C"
- I +MCC'=MCC S MCC=""""_MCC_""""
- I MCX=0,$D(^DD(+MCJ,.01,0)) G WD:$P(^(0),U,2)["W",SUBFIL ; yes
- I '$D(@(MCDIC_MCDA_","_MCC_")"))#2 S MCY="" G PROC
- S MCC=@(MCDIC_MCDA_","_MCC_")"),MCY=$S(MCX["E":$E(MCC,+$P(MCX,"E",2),+$P(MCX,",",2)),1:$P(MCC,U,MCX))
- I MCDIQ(0)["I",(MCDIQ(0)["N"&(MCY]"")!(MCDIQ(0)'["N")) S @(MCDIQ_"MCDI,MCDA,MCDIQ1,""I"")")=MCY
- PROC ;process a single datum
- Q:MCDIQ(0)'["E"&(MCDIQ(0)'="")&(MCDIQ(0)'["N") Q:MCDIQ(0)="IN"!(MCDIQ(0)="NI")
- I MCJ["C" S D0=MCD0,D1=$G(MCD1),X=MCX,Y=MCY X $P(MCY,U,5,999) K MCY,Y S MCX=X,MCY=MCX
- I MCJ'["C" S MCC=$P(^DD(MCDI,MCDIQ1,0),U,2) D:MCY]"" SPEC
- IF MCY'=""!(MCDIQ(0)'["N") D
- .S @(MCDIQ_MCE_",MCDI,MCDA,MCDIQ1,1)")=MCY
- Q
- WD ; word-processing field
- N MCWP,MCATT S MCWP=0
- F D WP2 Q:+MCX=0
- I MCWP'=0 S MCATT=$P(MCF,U,1)_"^W"
- E S MCATT="^^"
- ;S @("$P("_MCDIQ_"MCDI,MCDA,MCDIQ1,""F""),U,1,2)=MCATT")
- Q
- WP2 ; Note: We cannot be sure of the value of MCDIC.
- S MCX=$O(@(MCDIC_"MCDA,"_MCC_",MCX)")) Q:+MCX=0
- S @(MCDIQ_MCE_",MCDI,MCDA,MCDIQ1,MCX)")=^(MCX,0),MCWP=1
- Q
- SUBFIL ; process data in a sub-file
- Q:'$D(MCDR(+MCJ)) Q:'$D(MCDA(+MCJ)) N MCDIQ1,MCI,MCDI S MCDIL=MCDIL+1
- S MCDRS(MCDIL)=MCDR,MCDIC(MCDIL)=MCDIC,MCDR=MCDR(+MCJ),MCDA(MCDIL)=MCDA
- S MCDI=+MCJ,MCDIC=MCDIC_MCDA_","_MCC_",",MCDA=MCDA(+MCJ),@("MCD"_MCDIL)=MCDA
- D LEVEL S MCDR=MCDRS(MCDIL),MCDA=MCDA(MCDIL),MCDIC=MCDIC(MCDIL)
- K MCDRS(MCDIL),MCDIC(MCDIL),MCDA(MCDIL),@("MCD"_MCDIL)
- S MCDIL=MCDIL-1 Q
- SPEC ;
- I MCC["O",$D(^(2)) X ^(2) Q ;NAKED REFERENCE IS TO ^DD(FILE#,FIELD#,0)
- SPECS ;Naked Reference for this paragraph reference to ^DD(FILE#,FIELD,0)
- I MCC["S" S MCC=";"_$P(^(0),U,3),MCPCT=$F(MCC,";"_MCY_":") S:MCPCT MCY=$P($E(MCC,MCPCT,999),";",1) Q
- I MCC["P",$D(@("^"_$P(^(0),U,3)_"0)")) S MCC=$P(^(0),U,2) Q:'$D(^(MCY,0)) S MCY=$P(^(0),U) I $D(^DD(+MCC,.01,0)) S MCC=$P(^(0),U,2) G SPECS
- I MCC["V",+MCY,$D(@("^"_$P(MCY,";",2)_"0)")) S MCC=$P(^(0),U,2) Q:'$D(^(+MCY,0)) S MCY=$P(^(0),U) I $D(^DD(+MCC,.01,0)) S MCC=$P(^(0),U,2) G SPECS
- Q
- MCORMN2 ;WISC/MLH-NON-INTERACTIVE INQUIRY ;3/18/97 13:02
- +1 ;;2.3;Medicine;**4**;09/13/1996
- +2 NEW MCDIQ0
- +3 ;Q:'$D(MCDIC)!($D(MCDA)[0)!($D(MCDR)[0) S MCDIL=0,(MCDA(0),MCD0)=MCDA,MCDIQ0=""
- +4 IF '$DATA(MCDIC)!($DATA(MCDA)[0)!($ORDER(MCDRDR(0))'>0)
- QUIT
- SET MCDIL=0
- SET (MCDA(0),MCD0)=MCDA
- SET MCDIQ0=""
- +5 ;I $D(MCDIQ)#2 G Q:MCDIQ["^"!($E(MCDIQ,1,2)="DI") S:MCDIQ'["(" MCDIQ=MCDIQ_"("
- +6 IF '$DATA(MCDIQ(0))
- SET MCDIQ(0)=""
- SET MCDIQ0="MCDIQ(0),"
- +7 IF $DATA(MCDIQ)[0
- SET MCDIQ="^TMP(""MC"",$J,"
- SET MCDIQ0="MCDIQ,"
- +8 SET MCDIQ0=MCDIQ0_"MCDIQ0"
- SET MCE="""E"""
- +9 IF MCDIC
- SET MCDIC=$SELECT($DATA(^DIC(MCDIC,0,"GL")):^("GL"),1:"")
- IF MCDIC=""
- GOTO Q
- LEVEL ; handle data at this level
- +1 IF '$DATA(@(MCDIC_"0)"))
- GOTO Q
- SET MCDI=+$PIECE(^(0),U,2)
- IF '$DATA(^(MCDA,0))
- GOTO Q
- +2 ; Note: There is no way to be sure of the value of MCDIC.
- +3 ; We are assuming that it is ^DIC(MCDIC,0,"GL").
- +4 ;F I=1:1 S MCDIQ1=$P(MCDR,";",I) Q:MCDIQ1="" D COLON:MCDIQ1[":",FIELD:MCDIQ1>0
- +5 SET (I,MCDRDR)=0
- +6 FOR
- SET MCDRDR=$ORDER(MCDRDR(MCDRDR))
- SET I=I+1
- IF MCDRDR'>0
- QUIT
- SET MCDIQ1=MCDRDR(MCDRDR)
- IF MCDIQ1[":"
- DO COLON
- IF MCDIQ1>0
- DO FIELD
- Q IF MCDIL
- QUIT
- KILL MCPCT,MCF,MCI,MCJ,MCX,MCY,MCC,MCDA(0),MCDRS,MCDIL,MCDI,MCDIQ1,MCE,MCD0
- IF MCDIQ0]""
- KILL @MCDIQ0
- +1 QUIT
- COLON ; process set of fields delimited by colon
- +1 SET MCDIQ2=$PIECE(MCDIQ1,":",2)
- +2 FOR MCDIQ1=MCDIQ1:0
- DO FIELD
- SET MCDIQ1=$ORDER(^DD(MCDI,MCDIQ1))
- IF MCDIQ1'>0!(MCDIQ1'<MCDIQ2)
- IF MCDIQ1'=MCDIQ2
- SET MCDIQ1=0
- QUIT
- +3 QUIT
- FIELD ; process single field
- +1 IF '$DATA(^DD(MCDI,MCDIQ1,0))
- QUIT
- SET (MCF,MCY)=^(0)
- SET MCC=$PIECE(MCF,U,4)
- SET MCX=$PIECE(MCC,";",2)
- SET MCC=$PIECE(MCC,";",1)
- SET MCJ=$PIECE(MCF,U,2)
- IF MCJ["C"
- GOTO PROC
- +2 IF +MCC'=MCC
- SET MCC=""""_MCC_""""
- +3 ; yes
- IF MCX=0
- IF $DATA(^DD(+MCJ,.01,0))
- IF $PIECE(^(0),U,2)["W"
- GOTO WD
- GOTO SUBFIL
- +4 IF '$DATA(@(MCDIC_MCDA_","_MCC_")"))#2
- SET MCY=""
- GOTO PROC
- +5 SET MCC=@(MCDIC_MCDA_","_MCC_")")
- SET MCY=$SELECT(MCX["E":$EXTRACT(MCC,+$PIECE(MCX,"E",2),+$PIECE(MCX,",",2)),1:$PIECE(MCC,U,MCX))
- +6 IF MCDIQ(0)["I"
- IF (MCDIQ(0)["N"&(MCY]"")!(MCDIQ(0)'["N"))
- SET @(MCDIQ_"MCDI,MCDA,MCDIQ1,""I"")")=MCY
- PROC ;process a single datum
- +1 IF MCDIQ(0)'["E"&(MCDIQ(0)'="")&(MCDIQ(0)'["N")
- QUIT
- IF MCDIQ(0)="IN"!(MCDIQ(0)="NI")
- QUIT
- +2 IF MCJ["C"
- SET D0=MCD0
- SET D1=$GET(MCD1)
- SET X=MCX
- SET Y=MCY
- XECUTE $PIECE(MCY,U,5,999)
- KILL MCY,Y
- SET MCX=X
- SET MCY=MCX
- +3 IF MCJ'["C"
- SET MCC=$PIECE(^DD(MCDI,MCDIQ1,0),U,2)
- IF MCY]""
- DO SPEC
- +4 IF MCY'=""!(MCDIQ(0)'["N")
- Begin DoDot:1
- +5 SET @(MCDIQ_MCE_",MCDI,MCDA,MCDIQ1,1)")=MCY
- End DoDot:1
- +6 QUIT
- WD ; word-processing field
- +1 NEW MCWP,MCATT
- SET MCWP=0
- +2 FOR
- DO WP2
- IF +MCX=0
- QUIT
- +3 IF MCWP'=0
- SET MCATT=$PIECE(MCF,U,1)_"^W"
- +4 IF '$TEST
- SET MCATT="^^"
- +5 ;S @("$P("_MCDIQ_"MCDI,MCDA,MCDIQ1,""F""),U,1,2)=MCATT")
- +6 QUIT
- WP2 ; Note: We cannot be sure of the value of MCDIC.
- +1 SET MCX=$ORDER(@(MCDIC_"MCDA,"_MCC_",MCX)"))
- IF +MCX=0
- QUIT
- +2 SET @(MCDIQ_MCE_",MCDI,MCDA,MCDIQ1,MCX)")=^(MCX,0)
- SET MCWP=1
- +3 QUIT
- SUBFIL ; process data in a sub-file
- +1 IF '$DATA(MCDR(+MCJ))
- QUIT
- IF '$DATA(MCDA(+MCJ))
- QUIT
- NEW MCDIQ1,MCI,MCDI
- SET MCDIL=MCDIL+1
- +2 SET MCDRS(MCDIL)=MCDR
- SET MCDIC(MCDIL)=MCDIC
- SET MCDR=MCDR(+MCJ)
- SET MCDA(MCDIL)=MCDA
- +3 SET MCDI=+MCJ
- SET MCDIC=MCDIC_MCDA_","_MCC_","
- SET MCDA=MCDA(+MCJ)
- SET @("MCD"_MCDIL)=MCDA
- +4 DO LEVEL
- SET MCDR=MCDRS(MCDIL)
- SET MCDA=MCDA(MCDIL)
- SET MCDIC=MCDIC(MCDIL)
- +5 KILL MCDRS(MCDIL),MCDIC(MCDIL),MCDA(MCDIL),@("MCD"_MCDIL)
- +6 SET MCDIL=MCDIL-1
- QUIT
- SPEC ;
- +1 ;NAKED REFERENCE IS TO ^DD(FILE#,FIELD#,0)
- IF MCC["O"
- IF $DATA(^(2))
- XECUTE ^(2)
- QUIT
- SPECS ;Naked Reference for this paragraph reference to ^DD(FILE#,FIELD,0)
- +1 IF MCC["S"
- SET MCC=";"_$PIECE(^(0),U,3)
- SET MCPCT=$FIND(MCC,";"_MCY_":")
- IF MCPCT
- SET MCY=$PIECE($EXTRACT(MCC,MCPCT,999),";",1)
- QUIT
- +2 IF MCC["P"
- IF $DATA(@("^"_$PIECE(^(0),U,3)_"0)"))
- SET MCC=$PIECE(^(0),U,2)
- IF '$DATA(^(MCY,0))
- QUIT
- SET MCY=$PIECE(^(0),U)
- IF $DATA(^DD(+MCC,.01,0))
- SET MCC=$PIECE(^(0),U,2)
- GOTO SPECS
- +3 IF MCC["V"
- IF +MCY
- IF $DATA(@("^"_$PIECE(MCY,";",2)_"0)"))
- SET MCC=$PIECE(^(0),U,2)
- IF '$DATA(^(+MCY,0))
- QUIT
- SET MCY=$PIECE(^(0),U)
- IF $DATA(^DD(+MCC,.01,0))
- SET MCC=$PIECE(^(0),U,2)
- GOTO SPECS
- +4 QUIT
