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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCORMN2 3498 printed Dec 13, 2024@02:15:55 Page 2
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
