MCARDCM ;WISC/TJK-MODIFIED DICM ROUTINE FOR MEDICINE SCREENS ;7/19/96 15:18
;;2.3;Medicine;;09/13/1996
S:'$D(DICR(1)) DICR=0 I $A(X)=34,X?.E1"""" G N
G:$D(^DD(+DO(2),0,"LOOK")) @^("LOOK") I DIC(0)["U" S DD=0 G W
R S MCPCT="B",Y=+DO(2),MCPCTY=.01,DD=0 G 1
Z S MCPCT=$O(^DD(+DO(2),0,"IX",MCPCT)) S:MCPCT="" MCPCT=-1 S Y=$O(^(MCPCT,0)) S:Y="" Y=-1 S MCPCTY=$O(^(Y,0)) S:MCPCTY="" MCPCTY=-1 S DD=1
1 G 2:Y<0,Z:$D(DICR(U,Y,MCPCTY)),Z:D'=MCPCT&(DIC(0)'["M"),Z:'$D(^DD(Y,MCPCTY,0)) S DICR(U,Y,MCPCTY)=0,DS=^(0) I $D(^(7)) D RS K DS X ^(7) G Y
S DIX=Y F Y="P","D","S","V",-1 I $P(DS,U,2)[Y D A D:'Y ^MCARDCM1,D Q
Y G R:Y<0
2 G K:Y+1 I X?.E1L.E,DIC(0)'["X" D RS D LC^MCARDCM1 G K:Y+1
S DS="",DIX=$P(X,",",1) F MCPCT=2:1 S DD=$P(X,",",MCPCT) I DD'["""" S:$A(DD)=32 DD=$E(DD,2,999) Q:$L(DD)*2+$L(DS)>200!(DD="") S DS=DS_" I MCPCT?.E1P1"""_DD_""".E!(D'=""B""&(MCPCT?1"""_DD_""".E))"
; Naked References in 2+3 is refs by line tag 1
I DS]"",DIC(0)'["X" D RS S X=DIX,DS="S MCPCT=$P(^(0),U,1)"_DS,DIC(0)=DIC(0)_"D" D 7 G K:Y+1
I $L(X)>30 D RS S Y="DICR("_DICR_")",DS=$S(DIC(0)["X":"I $P(^(0),U,1)="_Y,1:"I '$L($P(^(0),"_Y_",1))"),X=$E(X,1,30) D 7
K S DD=$D(DICR(DICR,6)) K:'DICR DICR
I Y+1 K DIC("W") G R^MCARDC:DIC(0)["Z",Q^MCARDC
W D U G:'$T NL:DIC(0)["N",DD I DO(2)'["Z" S Y=0 F DS=1:1 S @("Y=$O("_DIC_"Y))") S:Y="" Y=-1 Q:Y'>0 W:DIC(0)["E"&(DS#20=0) ".." I $P(^(Y,0),U,1)=X X:$D(DIC("S")) DIC("S") I S DIY="" G GOT^MCARDC
NL I '$D(DICR) D NQ G GOT^MCARDC:$T
DD G B:DD
L I DIC(0)["L" K DD G ^MCARDCN
B G O^MCARDC1
;
N D RS S X=$E(X,2,$L(X)-1),DS=^DD(+DO(2),.01,0),MCPCT=D F Y="P","D","S","V" I $P(DS,U,2)[Y K:Y="P" DO D ^MCARDCM1 Q
S Y=-1 D L:$D(X),E G B:Y<0,2
;
A G MCPCT:'DD I '$D(^DD(DIX,MCPCTY,1,DD)) S DD=$O(^(DD)) S:DD="" DD=-1 G A:DD>0 S Y=-1 Q
; Naked ref in next line is to ^DD(DIX,MCPCTY,1, in previous line
I $S($D(^(DD,0)):$P(^(0),U,3,9)]"",1:1) S DD=DD+1 G A
MCPCT S DICR(DICR+1,4)=MCPCT I MCPCT'="B"!(DIC(0)'["L") S DICR(DICR+1,8)=1
I $D(DF) S DICR(DICR+1,9)=DF K DF
RS S DICR=DICR+1,DICR(DICR)=X,DICR(DICR,0)=DIC(0),DD="A" D DZ S DD="Q"
DZ S DIC(0)=$P(DIC(0),DD,1)_$P(DIC(0),DD,2) Q
;
D S (D,DF)=DICR(DICR,4),DD="M" S:D="B" DIC(0)=DIC(0)_"S" D DZ I $D(DS),$P(DS,U,2)["V" S DD="A" D DZ
RCR S DICRS=1
DIC ;
I $D(DICR(DICR,8)) S DD="L" D DZ
S Y=-1 I $D(X),$L(X)<31 D RENUM^MCARDC1
S:DIC(0)["L" DICR(DICR-1,6)=1 K:$D(DICR(DICR,4)) DF
E S D="B",MCPCT=DICR,X=DICR(MCPCT),DIC(0)=DICR(MCPCT,0),DICR=MCPCT-1 S:$D(DICR(MCPCT,9)) (D,DF)=DICR(MCPCT,9) K DICRS,DICR(MCPCT) D DO^MCARDC1:'$D(DO) Q
;
U I @("$O("_DIC_"""A[""))=""""")
Q
;
NQ I $L(X)<14,X?.NP,+X=X,@("$D("_DIC_"X,0))") S Y=X D S^MCARDC
Q
;
SOUNDEX I DIC(0)["E",'$D(DICRS) W " " D RS,SOU S DD="L" D DZ,RCR Q:Y>0
G R
;
7 S Y=-1,MCPCT=$S($D(DIC("S")):DIC("S"),1:1) I $D(DS),'$D(DIC("S1")) S DIC("S")=DS,DD="L" S:'MCPCT DIC("S")=DIC("S")_" X DIC(""S1"")",DIC("S1")=MCPCT D:X]"" DZ,F^MCARDC K DIC("S") S:$D(DIC("S1")) DIC("S")=DIC("S1") K DIC("S1")
G E
;
SOU G SOU^MCARDCM1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCARDCM 3007 printed Apr 09, 2024@21:14:24 Page 2
MCARDCM ;WISC/TJK-MODIFIED DICM ROUTINE FOR MEDICINE SCREENS ;7/19/96 15:18
+1 ;;2.3;Medicine;;09/13/1996
+2 if '$DATA(DICR(1))
SET DICR=0
IF $ASCII(X)=34
IF X?.E1""""
GOTO N
+3 if $DATA(^DD(+DO(2),0,"LOOK"))
GOTO @^("LOOK")
IF DIC(0)["U"
SET DD=0
GOTO W
R SET MCPCT="B"
SET Y=+DO(2)
SET MCPCTY=.01
SET DD=0
GOTO 1
Z SET MCPCT=$ORDER(^DD(+DO(2),0,"IX",MCPCT))
if MCPCT=""
SET MCPCT=-1
SET Y=$ORDER(^(MCPCT,0))
if Y=""
SET Y=-1
SET MCPCTY=$ORDER(^(Y,0))
if MCPCTY=""
SET MCPCTY=-1
SET DD=1
1 if Y<0
GOTO 2
if $DATA(DICR(U,Y,MCPCTY))
GOTO Z
if D'=MCPCT&(DIC(0)'["M")
GOTO Z
if '$DATA(^DD(Y,MCPCTY,0))
GOTO Z
SET DICR(U,Y,MCPCTY)=0
SET DS=^(0)
IF $DATA(^(7))
DO RS
KILL DS
XECUTE ^(7)
GOTO Y
+1 SET DIX=Y
FOR Y="P","D","S","V",-1
IF $PIECE(DS,U,2)[Y
DO A
if 'Y
DO ^MCARDCM1
DO D
QUIT
Y if Y<0
GOTO R
2 if Y+1
GOTO K
IF X?.E1L.E
IF DIC(0)'["X"
DO RS
DO LC^MCARDCM1
if Y+1
GOTO K
+1 SET DS=""
SET DIX=$PIECE(X,",",1)
FOR MCPCT=2:1
SET DD=$PIECE(X,",",MCPCT)
IF DD'[""""
if $ASCII(DD)=32
SET DD=$EXTRACT(DD,2,999)
if $LENGTH(DD)*2+$LENGTH(DS)>200!(DD="")
QUIT
SET DS=DS_" I MCPCT?.E1P1"""_DD_""".E!(D'=""B""&(MCPCT?1"""_DD_""".E))"
+2 ; Naked References in 2+3 is refs by line tag 1
+3 IF DS]""
IF DIC(0)'["X"
DO RS
SET X=DIX
SET DS="S MCPCT=$P(^(0),U,1)"_DS
SET DIC(0)=DIC(0)_"D"
DO 7
if Y+1
GOTO K
+4 IF $LENGTH(X)>30
DO RS
SET Y="DICR("_DICR_")"
SET DS=$SELECT(DIC(0)["X":"I $P(^(0),U,1)="_Y,1:"I '$L($P(^(0),"_Y_",1))")
SET X=$EXTRACT(X,1,30)
DO 7
K SET DD=$DATA(DICR(DICR,6))
if 'DICR
KILL DICR
+1 IF Y+1
KILL DIC("W")
if DIC(0)["Z"
GOTO R^MCARDC
GOTO Q^MCARDC
W DO U
if '$TEST
if DIC(0)["N"
GOTO NL
GOTO DD
IF DO(2)'["Z"
SET Y=0
FOR DS=1:1
SET @("Y=$O("_DIC_"Y))")
if Y=""
SET Y=-1
if Y'>0
QUIT
if DIC(0)["E"&(DS#20=0)
WRITE ".."
IF $PIECE(^(Y,0),U,1)=X
if $DATA(DIC("S"))
XECUTE DIC("S")
IF $TEST
SET DIY=""
GOTO GOT^MCARDC
NL IF '$DATA(DICR)
DO NQ
if $TEST
GOTO GOT^MCARDC
DD if DD
GOTO B
L IF DIC(0)["L"
KILL DD
GOTO ^MCARDCN
B GOTO O^MCARDC1
+1 ;
N DO RS
SET X=$EXTRACT(X,2,$LENGTH(X)-1)
SET DS=^DD(+DO(2),.01,0)
SET MCPCT=D
FOR Y="P","D","S","V"
IF $PIECE(DS,U,2)[Y
if Y="P"
KILL DO
DO ^MCARDCM1
QUIT
+1 SET Y=-1
if $DATA(X)
DO L
DO E
if Y<0
GOTO B
GOTO 2
+2 ;
A if 'DD
GOTO MCPCT
IF '$DATA(^DD(DIX,MCPCTY,1,DD))
SET DD=$ORDER(^(DD))
if DD=""
SET DD=-1
if DD>0
GOTO A
SET Y=-1
QUIT
+1 ; Naked ref in next line is to ^DD(DIX,MCPCTY,1, in previous line
+2 IF $SELECT($DATA(^(DD,0)):$PIECE(^(0),U,3,9)]"",1:1)
SET DD=DD+1
GOTO A
MCPCT SET DICR(DICR+1,4)=MCPCT
IF MCPCT'="B"!(DIC(0)'["L")
SET DICR(DICR+1,8)=1
+1 IF $DATA(DF)
SET DICR(DICR+1,9)=DF
KILL DF
RS SET DICR=DICR+1
SET DICR(DICR)=X
SET DICR(DICR,0)=DIC(0)
SET DD="A"
DO DZ
SET DD="Q"
DZ SET DIC(0)=$PIECE(DIC(0),DD,1)_$PIECE(DIC(0),DD,2)
QUIT
+1 ;
D SET (D,DF)=DICR(DICR,4)
SET DD="M"
if D="B"
SET DIC(0)=DIC(0)_"S"
DO DZ
IF $DATA(DS)
IF $PIECE(DS,U,2)["V"
SET DD="A"
DO DZ
RCR SET DICRS=1
DIC ;
+1 IF $DATA(DICR(DICR,8))
SET DD="L"
DO DZ
+2 SET Y=-1
IF $DATA(X)
IF $LENGTH(X)<31
DO RENUM^MCARDC1
+3 if DIC(0)["L"
SET DICR(DICR-1,6)=1
if $DATA(DICR(DICR,4))
KILL DF
E SET D="B"
SET MCPCT=DICR
SET X=DICR(MCPCT)
SET DIC(0)=DICR(MCPCT,0)
SET DICR=MCPCT-1
if $DATA(DICR(MCPCT,9))
SET (D,DF)=DICR(MCPCT,9)
KILL DICRS,DICR(MCPCT)
if '$DATA(DO)
DO DO^MCARDC1
QUIT
+1 ;
U IF @("$O("_DIC_"""A[""))=""""")
+1 QUIT
+2 ;
NQ IF $LENGTH(X)<14
IF X?.NP
IF +X=X
IF @("$D("_DIC_"X,0))")
SET Y=X
DO S^MCARDC
+1 QUIT
+2 ;
SOUNDEX IF DIC(0)["E"
IF '$DATA(DICRS)
WRITE " "
DO RS
DO SOU
SET DD="L"
DO DZ
DO RCR
if Y>0
QUIT
+1 GOTO R
+2 ;
7 SET Y=-1
SET MCPCT=$SELECT($DATA(DIC("S")):DIC("S"),1:1)
IF $DATA(DS)
IF '$DATA(DIC("S1"))
SET DIC("S")=DS
SET DD="L"
if 'MCPCT
SET DIC("S")=DIC("S")_" X DIC(""S1"")"
SET DIC("S1")=MCPCT
if X]""
DO DZ
DO F^MCARDC
KILL DIC("S")
if $DATA(DIC("S1"))
SET DIC("S")=DIC("S1")
KILL DIC("S1")
+1 GOTO E
+2 ;
SOU GOTO SOU^MCARDCM1
