source: FOIAVistA/trunk/r/MEDICINE-MC/MCARDCM1.m@ 811

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

initial load of FOIAVistA 6/30/08 version

File size: 2.6 KB
Line 
1MCARDCM1 ;WISC/TJK-MODIFIED DICM1 ROUTINE FOR MEDICINE SCREENS ;3/27/96 12:53
2 ;;2.3;Medicine;;09/13/1996
3 G @Y
4 ;
5P ;POINTERS
6 S DICR(DICR,1)=DIC,DIC=U_$P(DS,U,3),Y=DIC(0),D=$P(Y,"L",1)_$P(Y,"L",2),DICR(DICR,2)=$S(MCPCT="B":Y,1:D),DICR(DICR,2.1)=$S($P(DS,U,2)["'":D,1:Y)
7 S DIC(0)=$P(D,"N",1)_$P(D,"N",2)
8 F Y="S","P","W" I $D(DIC(Y)) S DICR(DICR,Y)=DIC(Y) K DIC(Y)
9AST G P1:$P(DS,U,2)'["*"
10 F D=" D ^DIC"," D IX^DIC"," D MIX^DIC1" S Y=$F(DS,D) I Y X $P($E(DS,1,Y-$L(D)-1),U,5,99) S:DS["DIC(0)=" DICR(DICR,2.1)=DIC(0) I $D(DIC("S")) S DICR(DICR,31)=DIC("S")
11P1 S Y="("_DICR(DICR,1) G L1:'$D(DO) K DO I @("$O"_Y_"0))'>0") G L1
12 S I="DIC"_DICR,D="X ""I 0"" F "_I_"=0:0 S "_I_"=$O"_Y,MCPCT=""""_MCPCT_""""
13 I @("$O"_Y_MCPCT_",0))>0") S D=D_MCPCT_",Y,"_I_")) S:"_I_"="""" "_I_"=-1 Q:"_I_"'>0 I $D"_Y_I_",0))"
14 E I DS["DINUM=X" S D="I $D"_Y_"Y,0))"
15 E S D=D_I_")) S:"_I_"="""" "_I_"=-1 Q:"_I_"'>0 I +^("_I_",0)=Y"
16 I $D(DICR(DICR,31)) S D="X DICR("_DICR_",31) "_D
17 I $D(DICR(DICR,"S")) S D=D_" S MCPCTY"_DICR_"=Y,Y="_I_" X DICR("_DICR_",""S"") S Y=MCPCTY"_DICR_" I "
18 S DIC("S")=D_" Q",D="B",Y=0 D X^MCARDC
19L1 K DIC("S"),@("DIC"_DICR) I Y'>0,'$D(DICR(DICR,8)) S:$D(DICR(DICR,31)) DIC("S")=DICR(DICR,31) G RETRY
20 I DICR(DICR,2)["L",DICR(DICR,2)["E",@("$P("_DIC_"0),U,2)'[""O""") W !?9,"...OK" S MCPCT=1 D YN^MCARDCN W ! I MCPCT-1 X DJCP G NO:MCPCT-2 S DIC("S")="I Y-"_+Y_$S($D(DICR(DICR,31)):" "_DICR(DICR,31),1:""),X=DICR(DICR) W ?5,X G RETRY
21R K DICW,DO,DIC("W"),DIC("S") S DIC=DICR(DICR,1),MCPCT=DICR(DICR,2),DIC(0)=$P(MCPCT,"M",1)_$P(MCPCT,"M",2) F X="S","P","W" S:$D(DICR(DICR,X)) DIC(X)=DICR(DICR,X)
22 D DO^MCARDC1 S X=+Y K:X'>0 X Q
23 ;
24RETRY D DO^MCARDC1 K DICR(U,+DO(2)) S D="B",DIC(0)=DICR(DICR,2.1) D X^MCARDC K DICR(DICR,6)
25 G R
26 ;
27NO S Y=-1 G R
28 ;
29D ;DATES
30 I $S(X?.N:X>49,1:1) S Y=$S($D(^DD(+DO(2),.001)):"N",1:"")_$P($P(DS,"%DT=""",2),"""",1),%DT=$P(Y,"E",1)_$P(Y,"E",2) D ^%DT S X=Y K %DT I X>1 Q:DIC(0)'["E" W " " G DT^DIQ
31 K X Q
32 ;
33S ;SETS
34 S DICR(DICR,1)=1,Y=$P(DS,U,3),DD=$P(";"_Y,";"_X_":",2) I DD]"" W:DIC(0)["E" " (",$P(DD,";",1),")" Q
35SS S DD=$P(Y,";",1),Y=$P(Y,";",2,99) I DD]"" G SS:DD'[(":"_X) W:DIC(0)["E" $P(DD,X,2,9) S X=$P(DD,":",1) Q
36 K X S Y=-1 Q
37 ;
38V ;VARIABLE POINTER
39 I X["?BAD" K X Q
40 G ^MCARDCM2
41 ;
42LC ;
43 Q:DIC(0)["X" S DIC(0)=$P(DIC(0),"L",1)_$P(DIC(0),"L",2)
44 F MCPCT=1:1 S Y=$E(X,MCPCT) I Y?.L Q:Y="" S X=$E(X,1,MCPCT-1)_$C($A(Y)-32)_$E(X,MCPCT+1,999)
45 G DIC^MCARDCM
46 ;
47SOU ;
48 S DSOU="01230129022455012623019202",DSOV=X,X=$C($A(X)-(X?1L.E*32)),DIX=$E(DSOU,$A(X)-64) F DIY=2:1 S Y=$E(DSOV,DIY) Q:","[Y I Y?1A S MCPCT=$E(DSOU,$A(Y)-$S(Y?1U:64,1:96)) I MCPCT-DIX,MCPCT-9 S DIX=MCPCT I MCPCT S X=X_MCPCT Q:$L(X)=4
49 S X=$E(X_"000",1,4) K DSOU,DSOV
Note: See TracBrowser for help on using the repository browser.