source: FOIAVistA/trunk/r/MEDICINE-MC/MCORMN3.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

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