80 lines
4.0 KiB
Mathematica
80 lines
4.0 KiB
Mathematica
MCARDCN1 ;WISC/TJK-MODIFIED DICN1 ROUTINE FOR MEDICINE SCREENS ;7/22/96 08:12
|
|
;;2.3;Medicine;;09/13/1996
|
|
K DICRS,Y,MCARDRCR
|
|
F Y="I","J","X","DO","DC","DA","DE","DG","DIE","DR","DIC","D","D0","D1","D2","D3","D4","D5","D6","DI","DH","DIA","DICR","DK","DIK","DL","DLAYGO","DM","DP","DQ","DU","DW","DIEL","DOV","DIOV","DIEC","DB","DV","DIFLD" S MCARDRCR(Y)=""
|
|
S DZ="W !?3,$S("""_$P(DO,U,1)_"""'=$P(DQ(DQ),U,1):"""_$P(DO,U,1)_""",1:"""")_"" ""_$P(DQ(DQ),U,1)_"": """
|
|
I $D(DIC("DR")) S DD=DIC("DR")
|
|
E S DD="",MCPCT=0 F Y=0:0 S Y=$O(^DD(+DO(2),0,"ID",Y)) S:Y="" Y=-1 Q:Y'>0 D CKID I '$D(MCPCT) D G BAD
|
|
. ; Naked Reference in DENTCN1+8 ref to DENTDCN1+6
|
|
. W !,"SORRY! A VALUE FOR '"_$P(^(0),U,1)_"' MUST BE ENTERED,"
|
|
. W !?6,"BUT YOU DON'T HAVE 'WRITE ACCESS' FOR THIS FIELD"
|
|
. S MCARDRCR="D^MCARDCN1"
|
|
. D STORLIST
|
|
. Q
|
|
;END IF
|
|
;
|
|
S MCARDRCR="RCR^MCARDCN1" D STORLIST G D^MCARDCN:$D(Y)<9
|
|
BAD S:$D(D)#2 DA=D K Y I '$D(DO(1)) S Y=-1 G Q^MCARDC
|
|
K DO G A^MCARDC
|
|
;
|
|
CKID I $D(DUZ(0)),DUZ(0)'="@",$D(^DD(+DO(2),Y,9)),^(9)]"" F MCPCT=1:1 I DUZ(0)[$E(^(9),MCPCT) Q:$L(^(9))'<MCPCT K:$P(^(0),U,2)["R" MCPCT G Q
|
|
S DD=DD_Y_";"
|
|
Q Q
|
|
;
|
|
RCR ;
|
|
K DR,DQ,DG,DE,DO S DIE=DIC,DR=DD,DIE("W")=DZ K DIC I $D(DIE("NO^")) S MCARDRCR("DIE(""NO^"")")=DIE("NO^")
|
|
S DIE("NO^")="OUTOK" D ^DIE K DIE("W"),DIE("NO^") I '$D(DA) S Y(0)=0 Q
|
|
Q:$D(Y)<9
|
|
ZAP S DIK=DIE W !?6,"<'",*7,$P(@(DIK_"DA,0)"),U,1),"' DELETED>" D ^DIK S Y(0)=0 K DIK Q
|
|
D S DIE=DIC G ZAP
|
|
;
|
|
RIX ;
|
|
K MCARDRCR F MCPCT="D0","Y","DIC","DIU","DIV","DO","D","DD","DICR","X" S MCARDRCR(MCPCT)=""
|
|
S MCARDRCR="RR^MCARDCN1",DZ=^DD(+DO(2),.01,1,1) D STORLIST G IX^MCARDCN
|
|
;
|
|
RR X DZ Q
|
|
;
|
|
NUM ;
|
|
I '$D(DD),DIC="^DIC(",$D(^DD("SITE",1)),X\1000'=^(1) S X=^(1)*1000 G F2^MCARDCN
|
|
S MCPCT=$P(^DD(+Y,.001,0),U,2),X=$S(MCPCT'["N"!(MCPCT["O"):0,1:X),MCPCTY=X I X F MCPCT=1:1 D N Q:$D(X) S X=0 Q:MCPCT>50 S X=MCPCTY+DIY,MCPCTY=X
|
|
W !?3,$P(DO,U,1)_" "_$P(^DD(+Y,.001,0),U,1),": " W:X X,"// " R Y:DTIME E S DTOUT=1,Y=U W *7
|
|
I Y="?" W:$D(^DD(+$P(D0,U,2),.001,3)) !,^(3) X:$D(^(4)) ^(4) G F1^MCARDCN
|
|
G BAD^MCARDC1:Y[U S:Y]"" X=Y D N I '$D(X) W *7,"??" W:$D(^DD(+DO(2),.001,3)) !,^(3) X:$D(^(4)) ^(4) G F1^MCARDCN
|
|
G LOCK^MCARDCN
|
|
;
|
|
N X:$D(^DD(+$P(DO,U,2),.001,0)) $P(^(0),U,5,99) I $D(X),$L(X)<15,+X=X,X>0,X>1!(DIC'="^DIC(") Q
|
|
K X
|
|
STORLIST ;
|
|
D INIT
|
|
O S MCARDJD=$O(MCARDRCR(MCARDJD)) S:MCARDJD="" MCARDJD=-1 G CALL:MCARDJD<0
|
|
I $D(@MCARDJD)#2 S @(MCARDJE_")="_MCARDJD) G O:$D(@MCARDJD)=1
|
|
S MCARDJX=MCARDJD_"(" D MCARDJXY G O
|
|
;
|
|
CALL S MCARDJE=MCARDRCR K MCARDRCR,MCARDJX,MCARDJY D @MCARDJE
|
|
S MCARDJE="^TMP(""MCARDRCR"",$J,"_^TMP("MCARDRCR",$J)_",MCARDJD",^($J)=^($J)-1,MCARDJD=0,MCARDJX=MCARDJE_","
|
|
G S MCARDJD=$O(@(MCARDJE_")")) S:MCARDJD="" MCARDJD=-1
|
|
; Naked reference in next line is to ^TMP("MCARDRCR",$J,
|
|
I MCARDJD<0 K MCARDJD,MCARDJE,MCARDJX,MCARDJY,^($J,^TMP("MCARDRCR",$J)+1) Q
|
|
K:$D(MCARDJD) @MCARDJD
|
|
; Naked reference in next line is to ^TMP("MCARDRCR",$J,
|
|
I $D(^(MCARDJD))#2 S @MCARDJD=^(MCARDJD) G G:$D(^(MCARDJD))=1
|
|
S MCARDJY=MCARDJD_"(" D MCARDJXY G G
|
|
;
|
|
MCARDJXY ;
|
|
S MCARDJZ=1,MCARDJA="",MCARDJC(0)=0
|
|
S S MCARDJB=-1
|
|
N1 S MCARDJB=$O(@(MCARDJX_MCARDJA_"MCARDJB)")) S:MCARDJB="" MCARDJB=-1 S MCARDJC(MCARDJZ)=MCARDJC(MCARDJZ-1)
|
|
I MCARDJB["," F MCARDJC=0:0 S MCARDJC=$F(MCARDJB,",",MCARDJC) Q:'MCARDJC S MCARDJC(MCARDJZ)=MCARDJC(MCARDJZ)+1
|
|
I MCARDJB=-1 G Q1:MCARDJZ=1 S MCARDJZ=MCARDJZ-1,@("MCARDJB="_$P(MCARDJA,",",MCARDJZ+MCARDJC(MCARDJZ-1),MCARDJZ+MCARDJC(MCARDJZ))),MCARDJA=$P(MCARDJA,",",1,MCARDJZ-1+MCARDJC(MCARDJZ-1))_$E(",",MCARDJZ>1) G N1
|
|
I $D(@(MCARDJX_MCARDJA_"MCARDJB)"))#10=1 S @(MCARDJY_MCARDJA_"MCARDJB)="_MCARDJX_MCARDJA_"MCARDJB)")
|
|
I $D(@(MCARDJX_MCARDJA_"MCARDJB)"))<9 G N1
|
|
G DOWN:+MCARDJB=MCARDJB F MCARDJC=0:0 S MCARDJC=$F(MCARDJB,"""",MCARDJC) Q:'MCARDJC S MCARDJB=$E(MCARDJB,1,MCARDJC-1)_""""_$E(MCARDJB,MCARDJC,999),MCARDJC=MCARDJC+1
|
|
S MCARDJB=""""_MCARDJB_""""
|
|
DOWN S MCARDJA=MCARDJA_MCARDJB_",",MCARDJZ=MCARDJZ+1 G S
|
|
;
|
|
Q1 K MCARDJA,MCARDJB,MCARDJC,MCARDJZ Q
|
|
;
|
|
INIT I $D(^TMP("MCARDRCR",$J))[0 S ^TMP("MCARDRCR",$J)=0
|
|
S ^TMP("MCARDRCR",$J)=^($J)+1,MCARDJD="MCPCTZ",MCARDJE="^TMP(""MCARDRCR"",$J,"_^($J)_",MCARDJD",MCARDJY=MCARDJE_"," K ^($J,^($J))
|
|
Q
|