MCARDC ;WISC/TJK-MODIFIED DIC ROUTINE FOR MEDICINE SCREENS ;1/14/94 11:07
;;2.3;Medicine;;09/13/1996
S D="B" K DF,DS,DFOUT,DTOUT,DUOUT
EN K DO,DICR S U="^" S:DIC DIC=^DIC(DIC,0,"GL") D PGM I $D(DIPGM) S DIPGM(0)=1 G @DIPGM
ASK I DIC(0)["A" W ! D ^MCARDC1
I $D(DIADD),X'["""",U'[X,X'?."?" S X=""""_X_""""
X ;
D DO^MCARDC1:'$D(DO) I U'[X,X'?."?",$D(^DD(+DO(2),.01,7.5)) X ^(7.5) G:'$D(X) BAD^MCARDC1
D PGM I $D(DIPGM) S DIPGM(0)=2 G @DIPGM
RTN ;
G O^MCARDC1:X'?.ANP,N:$L(X)>30 I X?.NP G NO:X="",NUM:+X=X,^MCARDCQ:X?1"?"."?" I X=" ",$L(DIC)<29,$D(^DISV(DUZ,DIC)) S Y=+^(DIC) D S G GOT:$T,BAD^MCARDC1
F ;
S (DD,DS)=0
T S Y=$O(@(DIC_"D,X,0)")),DIX=X S:Y="" Y=-1
I Y'<0 S YMLH=$O(^(Y)) S:YMLH="" YMLH=-1 G DIY:YMLH'<0!((DIC(0)'["O")&(DIC(0)["E")) D MN I G K:DS S DS=1 G GOT
; Naked refernces in T+1 to T.
DIX I DIC(0)'["X" S:X?.N DIX=DIX_" " S DIX=$O(@(DIC_"D,DIX)")) S:DIX="" DIX=-1 I $P(DIX,X,1)="",DIX'=-1 S Y=$O(^(DIX,0)) S:Y="" Y=-1 G DIY
M I DIC(0)'["M" G B
S D=$S($D(DID):$P(DID,U,DID(1)),1:$O(@(DIC_"D)")))
I D="" S D=-1
I $D(DID) S DID(1)=DID(1)+1
I D+1 G M:$D(@(DIC_"D)"))-10,T:X'?.NP,T:+X'=X D DO^MCARDC1:'$D(DO) S Y=$O(^DD(+DO(2),0,"IX",D,0)) S:Y="" Y=-1 S YY=$O(^(Y,0)) S:YY="" YY=-1 G T:'$D(^DD(Y,YY,0)),M:$P(^(0),U,2)["P",T
B D D G G:DS=1,Y^MCARDC1:DS
N I X[U S DUOUT=1 G NO
D DO^MCARDC1:'$D(DO) I X?1"`".NP S Y=$E(X,2,30),DZ=0 G A:Y="" D S S DS=1,DD=Y G GOT:$T I DIC(0)'["L" W:DIC(0)["Q" *7," ??" G A
G ^MCARDCQ:X?."?",^MCARDCM
;
NUM D DO^MCARDC1:'$D(DO) G ^MCARDCM:X<0,F:DO(2)<0!$D(DF) S DD=$D(^DD(+DO(2),.001)),DS=$P(^(.01,0),"^",2) I $D(@(DIC_"X)")) G:'DD P:DS["N"!'$O(^("A[")) S Y=X D S G GOT:$T
P I DS["P"!(DS["V"),DIC(0)'["U" S (DD,DS)=0 G M
G F
;
PGM K DIPGM I DIC(0)'["I",'$D(DF),$D(@(DIC_"0)")),$D(^DD(+$P(^(0),U,2),0,"DIC"))#2,"DI"'[$E(^("DIC"),1,2) S DIPGM=U_^("DIC")
Q
1 ;
D S G GOT:$T,F
;
; Naked reference in MN refs. to line Tag: PGM
MN S DZ=$S(DIC(0)["D":1,$D(^(Y))-1:0,1:^(Y)) D:'$D(DO) DO^MCARDC1 I 'DZ,'$D(DO("SCR")),$L(DIX)<30,D="B",'$D(DIC("S")) S DIY="" Q
D S S:D="B"&'DZ&($P(DIY,DIX,1)="") DIY=$P(DIY,DIX,2,9) Q
;
S D:'$D(DO) DO^MCARDC1 I $D(@(DIC_"Y,0)")) S DIY=$P(^(0),"^",1)
E S DIY="" Q
X:$D(DIC("S")) DIC("S") Q:'$T!'$D(DO("SCR")) I $D(@(DIC_"Y,0)")) X DO("SCR")
Q
;
Y X DJCP S Y=$O(@(DIC_"D,DIX,Y)"))
I Y="" S Y=-1
DIY I Y<0 G DIX:DIC(0)'["O"&(DIC(0)["E"),G:DS=1&(D="B")&(DIX=X),DIX
D MN E G Y
K F DZ=1:1:DS I $D(DS(DZ)),+DS(DZ)=Y,DIC(0)'["C" G Y
D DS^MCARDC1:'$D(DISMN) I $S<DISMN F DZ=1:1:DS-7 K DS(DZ),DIY(DZ)
S DS=DS+1,DS(DS)=Y_"^"_$P(DIX,X,2,99),DIY(DS)=DIY G Y:DS#5-1,Y:DS=1,Y:DIC(0)["Y",Y^MCARDC1
;
G S DIY=1,DIX=X I DIC(0)["E",DIC(0)'["D",'$D(DICRS) W $P(DS(1),"^",2)
C S Y=+DS(DIY),X=X_$P(DS(DIY),"^",2),DIY=DIY(DIY)
GOT D WO^MCARDC1:DIC(0)["E" S Y=Y_"^"_$S(DIY="":X,1:DIY) I DIC(0)["E",DO(2)["O" G OK^MCARDC1
R I $G(DIC(0))'["F",$D(DUZ)#2 S ^DISV(DUZ,$E(DIC,1,28))=$E(DIC,29,999)_+Y
I $G(DIC(0))["Z" K D S:$D(C) D=C S Y(0)=@(DIC_"+Y,0)"),DJC=+DO(2),DS=Y,Y=$P(Y(0),U,1) D Y^MCARDCM2 K DJC S Y(0,0)=Y,Y=DS,Y(0)=@(DIC_"+Y,0)") S:$D(D) C=D
I $D(DO(2)),$D(^DD(+DO(2),0,"ACT"))#2 X ^("ACT")
S:'$D(Y) Y=-1 I $D(@(DIC_"+Y,0)"))
Q K DID,DISMN,DIC("W"),DINUM,DS,DF,DD,DIX,DIY,DZ,DO,D Q
;
D S D=$S($D(DF):DF,1:"B") S:$D(DID(1)) DID(1)=2 Q
;
IX S DF=D G EN
;
A K DIY,DS I DIC(0)["A" D D G ASK
NO S Y=-1 G Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCARDC 3357 printed Jan 18, 2025@03:13:38 Page 2
MCARDC ;WISC/TJK-MODIFIED DIC ROUTINE FOR MEDICINE SCREENS ;1/14/94 11:07
+1 ;;2.3;Medicine;;09/13/1996
+2 SET D="B"
KILL DF,DS,DFOUT,DTOUT,DUOUT
EN KILL DO,DICR
SET U="^"
if DIC
SET DIC=^DIC(DIC,0,"GL")
DO PGM
IF $DATA(DIPGM)
SET DIPGM(0)=1
GOTO @DIPGM
ASK IF DIC(0)["A"
WRITE !
DO ^MCARDC1
+1 IF $DATA(DIADD)
IF X'[""""
IF U'[X
IF X'?."?"
SET X=""""_X_""""
X ;
+1 if '$DATA(DO)
DO DO^MCARDC1
IF U'[X
IF X'?."?"
IF $DATA(^DD(+DO(2),.01,7.5))
XECUTE ^(7.5)
if '$DATA(X)
GOTO BAD^MCARDC1
+2 DO PGM
IF $DATA(DIPGM)
SET DIPGM(0)=2
GOTO @DIPGM
RTN ;
+1 if X'?.ANP
GOTO O^MCARDC1
if $LENGTH(X)>30
GOTO N
IF X?.NP
if X=""
GOTO NO
if +X=X
GOTO NUM
if X?1"?"."?"
GOTO ^MCARDCQ
IF X=" "
IF $LENGTH(DIC)<29
IF $DATA(^DISV(DUZ,DIC))
SET Y=+^(DIC)
DO S
if $TEST
GOTO GOT
GOTO BAD^MCARDC1
F ;
+1 SET (DD,DS)=0
T SET Y=$ORDER(@(DIC_"D,X,0)"))
SET DIX=X
if Y=""
SET Y=-1
+1 IF Y'<0
SET YMLH=$ORDER(^(Y))
if YMLH=""
SET YMLH=-1
if YMLH'<0!((DIC(0)'["O")&(DIC(0)["E"))
GOTO DIY
DO MN
IF $TEST
if DS
GOTO K
SET DS=1
GOTO GOT
+2 ; Naked refernces in T+1 to T.
DIX IF DIC(0)'["X"
if X?.N
SET DIX=DIX_" "
SET DIX=$ORDER(@(DIC_"D,DIX)"))
if DIX=""
SET DIX=-1
IF $PIECE(DIX,X,1)=""
IF DIX'=-1
SET Y=$ORDER(^(DIX,0))
if Y=""
SET Y=-1
GOTO DIY
M IF DIC(0)'["M"
GOTO B
+1 SET D=$SELECT($DATA(DID):$PIECE(DID,U,DID(1)),1:$ORDER(@(DIC_"D)")))
+2 IF D=""
SET D=-1
+3 IF $DATA(DID)
SET DID(1)=DID(1)+1
+4 IF D+1
if $DATA(@(DIC_"D)"))-10
GOTO M
if X'?.NP
GOTO T
if +X'=X
GOTO T
if '$DATA(DO)
DO DO^MCARDC1
SET Y=$ORDER(^DD(+DO(2),0,"IX",D,0))
if Y=""
SET Y=-1
SET YY=$ORDER(^(Y,0))
if YY=""
SET YY=-1
if '$DATA(^DD(Y,YY,0))
GOTO T
if $PIECE(^(0),U,2)["P"
GOTO M
GOTO T
B DO D
if DS=1
GOTO G
if DS
GOTO Y^MCARDC1
N IF X[U
SET DUOUT=1
GOTO NO
+1 if '$DATA(DO)
DO DO^MCARDC1
IF X?1"`".NP
SET Y=$EXTRACT(X,2,30)
SET DZ=0
if Y=""
GOTO A
DO S
SET DS=1
SET DD=Y
if $TEST
GOTO GOT
IF DIC(0)'["L"
if DIC(0)["Q"
WRITE *7," ??"
GOTO A
+2 if X?."?"
GOTO ^MCARDCQ
GOTO ^MCARDCM
+3 ;
NUM if '$DATA(DO)
DO DO^MCARDC1
if X<0
GOTO ^MCARDCM
if DO(2)<0!$DATA(DF)
GOTO F
SET DD=$DATA(^DD(+DO(2),.001))
SET DS=$PIECE(^(.01,0),"^",2)
IF $DATA(@(DIC_"X)"))
if 'DD
if DS["N"!'$ORDER(^("A["))
GOTO P
SET Y=X
DO S
if $TEST
GOTO GOT
P IF DS["P"!(DS["V")
IF DIC(0)'["U"
SET (DD,DS)=0
GOTO M
+1 GOTO F
+2 ;
PGM KILL DIPGM
IF DIC(0)'["I"
IF '$DATA(DF)
IF $DATA(@(DIC_"0)"))
IF $DATA(^DD(+$PIECE(^(0),U,2),0,"DIC"))#2
IF "DI"'[$EXTRACT(^("DIC"),1,2)
SET DIPGM=U_^("DIC")
+1 QUIT
1 ;
+1 DO S
if $TEST
GOTO GOT
GOTO F
+2 ;
+3 ; Naked reference in MN refs. to line Tag: PGM
MN SET DZ=$SELECT(DIC(0)["D":1,$DATA(^(Y))-1:0,1:^(Y))
if '$DATA(DO)
DO DO^MCARDC1
IF 'DZ
IF '$DATA(DO("SCR"))
IF $LENGTH(DIX)<30
IF D="B"
IF '$DATA(DIC("S"))
SET DIY=""
QUIT
+1 DO S
if D="B"&'DZ&($PIECE(DIY,DIX,1)="")
SET DIY=$PIECE(DIY,DIX,2,9)
QUIT
+2 ;
S if '$DATA(DO)
DO DO^MCARDC1
IF $DATA(@(DIC_"Y,0)"))
SET DIY=$PIECE(^(0),"^",1)
+1 IF '$TEST
SET DIY=""
QUIT
+2 if $DATA(DIC("S"))
XECUTE DIC("S")
if '$TEST!'$DATA(DO("SCR"))
QUIT
IF $DATA(@(DIC_"Y,0)"))
XECUTE DO("SCR")
+3 QUIT
+4 ;
Y XECUTE DJCP
SET Y=$ORDER(@(DIC_"D,DIX,Y)"))
+1 IF Y=""
SET Y=-1
DIY IF Y<0
if DIC(0)'["O"&(DIC(0)["E")
GOTO DIX
if DS=1&(D="B")&(DIX=X)
GOTO G
GOTO DIX
+1 DO MN
IF '$TEST
GOTO Y
K FOR DZ=1:1:DS
IF $DATA(DS(DZ))
IF +DS(DZ)=Y
IF DIC(0)'["C"
GOTO Y
+1 if '$DATA(DISMN)
DO DS^MCARDC1
IF $STORAGE<DISMN
FOR DZ=1:1:DS-7
KILL DS(DZ),DIY(DZ)
+2 SET DS=DS+1
SET DS(DS)=Y_"^"_$PIECE(DIX,X,2,99)
SET DIY(DS)=DIY
if DS#5-1
GOTO Y
if DS=1
GOTO Y
if DIC(0)["Y"
GOTO Y
GOTO Y^MCARDC1
+3 ;
G SET DIY=1
SET DIX=X
IF DIC(0)["E"
IF DIC(0)'["D"
IF '$DATA(DICRS)
WRITE $PIECE(DS(1),"^",2)
C SET Y=+DS(DIY)
SET X=X_$PIECE(DS(DIY),"^",2)
SET DIY=DIY(DIY)
GOT if DIC(0)["E"
DO WO^MCARDC1
SET Y=Y_"^"_$SELECT(DIY="":X,1:DIY)
IF DIC(0)["E"
IF DO(2)["O"
GOTO OK^MCARDC1
R IF $GET(DIC(0))'["F"
IF $DATA(DUZ)#2
SET ^DISV(DUZ,$EXTRACT(DIC,1,28))=$EXTRACT(DIC,29,999)_+Y
+1 IF $GET(DIC(0))["Z"
KILL D
if $DATA(C)
SET D=C
SET Y(0)=@(DIC_"+Y,0)")
SET DJC=+DO(2)
SET DS=Y
SET Y=$PIECE(Y(0),U,1)
DO Y^MCARDCM2
KILL DJC
SET Y(0,0)=Y
SET Y=DS
SET Y(0)=@(DIC_"+Y,0)")
if $DATA(D)
SET C=D
+2 IF $DATA(DO(2))
IF $DATA(^DD(+DO(2),0,"ACT"))#2
XECUTE ^("ACT")
+3 if '$DATA(Y)
SET Y=-1
IF $DATA(@(DIC_"+Y,0)"))
Q KILL DID,DISMN,DIC("W"),DINUM,DS,DF,DD,DIX,DIY,DZ,DO,D
QUIT
+1 ;
D SET D=$SELECT($DATA(DF):DF,1:"B")
if $DATA(DID(1))
SET DID(1)=2
QUIT
+1 ;
IX SET DF=D
GOTO EN
+1 ;
A KILL DIY,DS
IF DIC(0)["A"
DO D
GOTO ASK
NO SET Y=-1
GOTO Q
