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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCARDCN1 4225 printed Apr 09, 2024@21:18:23 Page 2
MCARDCN1 ;WISC/TJK-MODIFIED DICN1 ROUTINE FOR MEDICINE SCREENS ;7/22/96 08:12
+1 ;;2.3;Medicine;;09/13/1996
+2 KILL DICRS,Y,MCARDRCR
+3 FOR 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"
SET MCARDRCR(Y)=""
+4 SET DZ="W !?3,$S("""_$PIECE(DO,U,1)_"""'=$P(DQ(DQ),U,1):"""_$PIECE(DO,U,1)_""",1:"""")_"" ""_$P(DQ(DQ),U,1)_"": """
+5 IF $DATA(DIC("DR"))
SET DD=DIC("DR")
+6 IF '$TEST
SET DD=""
SET MCPCT=0
FOR Y=0:0
SET Y=$ORDER(^DD(+DO(2),0,"ID",Y))
if Y=""
SET Y=-1
if Y'>0
QUIT
DO CKID
IF '$DATA(MCPCT)
Begin DoDot:1
+7 ; Naked Reference in DENTCN1+8 ref to DENTDCN1+6
+8 WRITE !,"SORRY! A VALUE FOR '"_$PIECE(^(0),U,1)_"' MUST BE ENTERED,"
+9 WRITE !?6,"BUT YOU DON'T HAVE 'WRITE ACCESS' FOR THIS FIELD"
+10 SET MCARDRCR="D^MCARDCN1"
+11 DO STORLIST
+12 QUIT
End DoDot:1
GOTO BAD
+13 ;END IF
+14 ;
+15 SET MCARDRCR="RCR^MCARDCN1"
DO STORLIST
if $DATA(Y)<9
GOTO D^MCARDCN
BAD if $DATA(D)#2
SET DA=D
KILL Y
IF '$DATA(DO(1))
SET Y=-1
GOTO Q^MCARDC
+1 KILL DO
GOTO A^MCARDC
+2 ;
CKID IF $DATA(DUZ(0))
IF DUZ(0)'="@"
IF $DATA(^DD(+DO(2),Y,9))
IF ^(9)]""
FOR MCPCT=1:1
IF DUZ(0)[$EXTRACT(^(9),MCPCT)
if $LENGTH(^(9))'<MCPCT
QUIT
if $PIECE(^(0),U,2)["R"
KILL MCPCT
GOTO Q
+1 SET DD=DD_Y_";"
Q QUIT
+1 ;
RCR ;
+1 KILL DR,DQ,DG,DE,DO
SET DIE=DIC
SET DR=DD
SET DIE("W")=DZ
KILL DIC
IF $DATA(DIE("NO^"))
SET MCARDRCR("DIE(""NO^"")")=DIE("NO^")
+2 SET DIE("NO^")="OUTOK"
DO ^DIE
KILL DIE("W"),DIE("NO^")
IF '$DATA(DA)
SET Y(0)=0
QUIT
+3 if $DATA(Y)<9
QUIT
ZAP SET DIK=DIE
WRITE !?6,"<'",*7,$PIECE(@(DIK_"DA,0)"),U,1),"' DELETED>"
DO ^DIK
SET Y(0)=0
KILL DIK
QUIT
D SET DIE=DIC
GOTO ZAP
+1 ;
RIX ;
+1 KILL MCARDRCR
FOR MCPCT="D0","Y","DIC","DIU","DIV","DO","D","DD","DICR","X"
SET MCARDRCR(MCPCT)=""
+2 SET MCARDRCR="RR^MCARDCN1"
SET DZ=^DD(+DO(2),.01,1,1)
DO STORLIST
GOTO IX^MCARDCN
+3 ;
RR XECUTE DZ
QUIT
+1 ;
NUM ;
+1 IF '$DATA(DD)
IF DIC="^DIC("
IF $DATA(^DD("SITE",1))
IF X\1000'=^(1)
SET X=^(1)*1000
GOTO F2^MCARDCN
+2 SET MCPCT=$PIECE(^DD(+Y,.001,0),U,2)
SET X=$SELECT(MCPCT'["N"!(MCPCT["O"):0,1:X)
SET MCPCTY=X
IF X
FOR MCPCT=1:1
DO N
if $DATA(X)
QUIT
SET X=0
if MCPCT>50
QUIT
SET X=MCPCTY+DIY
SET MCPCTY=X
+3 WRITE !?3,$PIECE(DO,U,1)_" "_$PIECE(^DD(+Y,.001,0),U,1),": "
if X
WRITE X,"// "
READ Y:DTIME
IF '$TEST
SET DTOUT=1
SET Y=U
WRITE *7
+4 IF Y="?"
if $DATA(^DD(+$PIECE(D0,U,2),.001,3))
WRITE !,^(3)
if $DATA(^(4))
XECUTE ^(4)
GOTO F1^MCARDCN
+5 if Y[U
GOTO BAD^MCARDC1
if Y]""
SET X=Y
DO N
IF '$DATA(X)
WRITE *7,"??"
if $DATA(^DD(+DO(2),.001,3))
WRITE !,^(3)
if $DATA(^(4))
XECUTE ^(4)
GOTO F1^MCARDCN
+6 GOTO LOCK^MCARDCN
+7 ;
N if $DATA(^DD(+$PIECE(DO,U,2),.001,0))
XECUTE $PIECE(^(0),U,5,99)
IF $DATA(X)
IF $LENGTH(X)<15
IF +X=X
IF X>0
IF X>1!(DIC'="^DIC(")
QUIT
+1 KILL X
STORLIST ;
+1 DO INIT
O SET MCARDJD=$ORDER(MCARDRCR(MCARDJD))
if MCARDJD=""
SET MCARDJD=-1
if MCARDJD<0
GOTO CALL
+1 IF $DATA(@MCARDJD)#2
SET @(MCARDJE_")="_MCARDJD)
if $DATA(@MCARDJD)=1
GOTO O
+2 SET MCARDJX=MCARDJD_"("
DO MCARDJXY
GOTO O
+3 ;
CALL SET MCARDJE=MCARDRCR
KILL MCARDRCR,MCARDJX,MCARDJY
DO @MCARDJE
+1 SET MCARDJE="^TMP(""MCARDRCR"",$J,"_^TMP("MCARDRCR",$JOB)_",MCARDJD"
SET ^($JOB)=^($JOB)-1
SET MCARDJD=0
SET MCARDJX=MCARDJE_","
G SET MCARDJD=$ORDER(@(MCARDJE_")"))
if MCARDJD=""
SET MCARDJD=-1
+1 ; Naked reference in next line is to ^TMP("MCARDRCR",$J,
+2 IF MCARDJD<0
KILL MCARDJD,MCARDJE,MCARDJX,MCARDJY,^($JOB,^TMP("MCARDRCR",$JOB)+1)
QUIT
+3 if $DATA(MCARDJD)
KILL @MCARDJD
+4 ; Naked reference in next line is to ^TMP("MCARDRCR",$J,
+5 IF $DATA(^(MCARDJD))#2
SET @MCARDJD=^(MCARDJD)
if $DATA(^(MCARDJD))=1
GOTO G
+6 SET MCARDJY=MCARDJD_"("
DO MCARDJXY
GOTO G
+7 ;
MCARDJXY ;
+1 SET MCARDJZ=1
SET MCARDJA=""
SET MCARDJC(0)=0
S SET MCARDJB=-1
N1 SET MCARDJB=$ORDER(@(MCARDJX_MCARDJA_"MCARDJB)"))
if MCARDJB=""
SET MCARDJB=-1
SET MCARDJC(MCARDJZ)=MCARDJC(MCARDJZ-1)
+1 IF MCARDJB[","
FOR MCARDJC=0:0
SET MCARDJC=$FIND(MCARDJB,",",MCARDJC)
if 'MCARDJC
QUIT
SET MCARDJC(MCARDJZ)=MCARDJC(MCARDJZ)+1
+2 IF MCARDJB=-1
if MCARDJZ=1
GOTO Q1
SET MCARDJZ=MCARDJZ-1
SET @("MCARDJB="_$PIECE(MCARDJA,",",MCARDJZ+MCARDJC(MCARDJZ-1),MCARDJZ+MCARDJC(MCARDJZ)))
SET MCARDJA=$PIECE(MCARDJA,",",1,MCARDJZ-1+MCARDJC(MCARDJZ-1))_$EXTRACT(",",MCARDJZ>1)
GOTO N1
+3 IF $DATA(@(MCARDJX_MCARDJA_"MCARDJB)"))#10=1
SET @(MCARDJY_MCARDJA_"MCARDJB)="_MCARDJX_MCARDJA_"MCARDJB)")
+4 IF $DATA(@(MCARDJX_MCARDJA_"MCARDJB)"))<9
GOTO N1
+5 if +MCARDJB=MCARDJB
GOTO DOWN
FOR MCARDJC=0:0
SET MCARDJC=$FIND(MCARDJB,"""",MCARDJC)
if 'MCARDJC
QUIT
SET MCARDJB=$EXTRACT(MCARDJB,1,MCARDJC-1)_""""_$EXTRACT(MCARDJB,MCARDJC,999)
SET MCARDJC=MCARDJC+1
+6 SET MCARDJB=""""_MCARDJB_""""
DOWN SET MCARDJA=MCARDJA_MCARDJB_","
SET MCARDJZ=MCARDJZ+1
GOTO S
+1 ;
Q1 KILL MCARDJA,MCARDJB,MCARDJC,MCARDJZ
QUIT
+1 ;
INIT IF $DATA(^TMP("MCARDRCR",$JOB))[0
SET ^TMP("MCARDRCR",$JOB)=0
+1 SET ^TMP("MCARDRCR",$JOB)=^($JOB)+1
SET MCARDJD="MCPCTZ"
SET MCARDJE="^TMP(""MCARDRCR"",$J,"_^($JOB)_",MCARDJD"
SET MCARDJY=MCARDJE_","
KILL ^($JOB,^($JOB))
+2 QUIT
