source: FOIAVistA/trunk/r/MEDICINE-MC/MCORMN2.m@ 1607

Last change on this file since 1607 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.4 KB
Line 
1MCORMN2 ;WISC/MLH-NON-INTERACTIVE INQUIRY ;3/18/97 13:02
2 ;;2.3;Medicine;**4**;09/13/1996
3 N MCDIQ0
4 ;Q:'$D(MCDIC)!($D(MCDA)[0)!($D(MCDR)[0) S MCDIL=0,(MCDA(0),MCD0)=MCDA,MCDIQ0=""
5 Q:'$D(MCDIC)!($D(MCDA)[0)!($O(MCDRDR(0))'>0) S MCDIL=0,(MCDA(0),MCD0)=MCDA,MCDIQ0=""
6 ;I $D(MCDIQ)#2 G Q:MCDIQ["^"!($E(MCDIQ,1,2)="DI") S:MCDIQ'["(" MCDIQ=MCDIQ_"("
7 S:'$D(MCDIQ(0)) MCDIQ(0)="",MCDIQ0="MCDIQ(0),"
8 I $D(MCDIQ)[0 S MCDIQ="^TMP(""MC"",$J,",MCDIQ0="MCDIQ,"
9 S MCDIQ0=MCDIQ0_"MCDIQ0",MCE="""E"""
10 I MCDIC S MCDIC=$S($D(^DIC(MCDIC,0,"GL")):^("GL"),1:"") G:MCDIC="" Q
11LEVEL ; handle data at this level
12 G Q:'$D(@(MCDIC_"0)")) S MCDI=+$P(^(0),U,2) G Q:'$D(^(MCDA,0))
13 ; Note: There is no way to be sure of the value of MCDIC.
14 ; We are assuming that it is ^DIC(MCDIC,0,"GL").
15 ;F I=1:1 S MCDIQ1=$P(MCDR,";",I) Q:MCDIQ1="" D COLON:MCDIQ1[":",FIELD:MCDIQ1>0
16 S (I,MCDRDR)=0
17 F S MCDRDR=$O(MCDRDR(MCDRDR)),I=I+1 Q:MCDRDR'>0 S MCDIQ1=MCDRDR(MCDRDR) D COLON:MCDIQ1[":",FIELD:MCDIQ1>0
18Q Q:MCDIL K MCPCT,MCF,MCI,MCJ,MCX,MCY,MCC,MCDA(0),MCDRS,MCDIL,MCDI,MCDIQ1,MCE,MCD0 K:MCDIQ0]"" @MCDIQ0
19 Q
20COLON ; process set of fields delimited by colon
21 S MCDIQ2=$P(MCDIQ1,":",2)
22 F MCDIQ1=MCDIQ1:0 D FIELD S MCDIQ1=$O(^DD(MCDI,MCDIQ1)) I MCDIQ1'>0!(MCDIQ1'<MCDIQ2) S:MCDIQ1'=MCDIQ2 MCDIQ1=0 Q
23 Q
24FIELD ; process single field
25 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"
26 I +MCC'=MCC S MCC=""""_MCC_""""
27 I MCX=0,$D(^DD(+MCJ,.01,0)) G WD:$P(^(0),U,2)["W",SUBFIL ; yes
28 I '$D(@(MCDIC_MCDA_","_MCC_")"))#2 S MCY="" G PROC
29 S MCC=@(MCDIC_MCDA_","_MCC_")"),MCY=$S(MCX["E":$E(MCC,+$P(MCX,"E",2),+$P(MCX,",",2)),1:$P(MCC,U,MCX))
30 I MCDIQ(0)["I",(MCDIQ(0)["N"&(MCY]"")!(MCDIQ(0)'["N")) S @(MCDIQ_"MCDI,MCDA,MCDIQ1,""I"")")=MCY
31PROC ;process a single datum
32 Q:MCDIQ(0)'["E"&(MCDIQ(0)'="")&(MCDIQ(0)'["N") Q:MCDIQ(0)="IN"!(MCDIQ(0)="NI")
33 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
34 I MCJ'["C" S MCC=$P(^DD(MCDI,MCDIQ1,0),U,2) D:MCY]"" SPEC
35 IF MCY'=""!(MCDIQ(0)'["N") D
36 .S @(MCDIQ_MCE_",MCDI,MCDA,MCDIQ1,1)")=MCY
37 Q
38WD ; word-processing field
39 N MCWP,MCATT S MCWP=0
40 F D WP2 Q:+MCX=0
41 I MCWP'=0 S MCATT=$P(MCF,U,1)_"^W"
42 E S MCATT="^^"
43 ;S @("$P("_MCDIQ_"MCDI,MCDA,MCDIQ1,""F""),U,1,2)=MCATT")
44 Q
45WP2 ; Note: We cannot be sure of the value of MCDIC.
46 S MCX=$O(@(MCDIC_"MCDA,"_MCC_",MCX)")) Q:+MCX=0
47 S @(MCDIQ_MCE_",MCDI,MCDA,MCDIQ1,MCX)")=^(MCX,0),MCWP=1
48 Q
49SUBFIL ; process data in a sub-file
50 Q:'$D(MCDR(+MCJ)) Q:'$D(MCDA(+MCJ)) N MCDIQ1,MCI,MCDI S MCDIL=MCDIL+1
51 S MCDRS(MCDIL)=MCDR,MCDIC(MCDIL)=MCDIC,MCDR=MCDR(+MCJ),MCDA(MCDIL)=MCDA
52 S MCDI=+MCJ,MCDIC=MCDIC_MCDA_","_MCC_",",MCDA=MCDA(+MCJ),@("MCD"_MCDIL)=MCDA
53 D LEVEL S MCDR=MCDRS(MCDIL),MCDA=MCDA(MCDIL),MCDIC=MCDIC(MCDIL)
54 K MCDRS(MCDIL),MCDIC(MCDIL),MCDA(MCDIL),@("MCD"_MCDIL)
55 S MCDIL=MCDIL-1 Q
56SPEC ;
57 I MCC["O",$D(^(2)) X ^(2) Q ;NAKED REFERENCE IS TO ^DD(FILE#,FIELD#,0)
58SPECS ;Naked Reference for this paragraph reference to ^DD(FILE#,FIELD,0)
59 I MCC["S" S MCC=";"_$P(^(0),U,3),MCPCT=$F(MCC,";"_MCY_":") S:MCPCT MCY=$P($E(MCC,MCPCT,999),";",1) Q
60 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
61 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
62 Q
Note: See TracBrowser for help on using the repository browser.