MCARDC1 ;WISC/TJK-READ X, SET UP ID'S, ASK OK ;7/19/96 15:06
;;2.3;Medicine;;09/13/1996
I $D(DIC("A")) S DD=DIC("A") G B
D DO S Y=$P(DO,"^",1) I D="B",DO(2)>1.9 S X=$P(^DD(+DO(2),.01,0),"^",1) I X'[Y,Y'[X S Y=Y_" "_X
S DD="Select "_Y_": "
B I $D(DIC("B")),DIC("B")]"" S Y=DIC("B"),X=$O(@(DIC_"D,Y)")) S:X="" X=-1 S DIY=$S($D(^(Y)):Y,$F(X,Y)-1=$L(Y):X,$D(@(DIC_"Y,0)")):$P(^(0),U),1:Y) W DD D WR R "// ",X:DTIME G DO:X]"",TIME:'$T S X=DIY S:DIC(0)'["O" DIC(0)=DIC(0)_"O" G DO
W DD R X:DTIME E G TIME:X=""
DO ;
; Naked references in DO+2 is the global in the variable DIC
Q:$D(DO) I $D(@(DIC_"0)")) S DO=^(0)
E S DO="0^-1" I $D(DIC("P")) S DO=U_DIC("P"),^(0)=DO
DO2 S DO(2)=$P(DO,"^",2) I DO?1"^".E S YMLH=$O(^DD(+DO(2),0,"NM",0)) S:YMLH="" YMLH=-1 S DO=YMLH_DO
I DO(2)["s",$D(^DD(+DO(2),0,"SCR")) S DO("SCR")=^("SCR")
Q:DO(2)'["I"!$D(DIC("W")) Q:'$D(^DD(+DO(2),0,"ID")) S MCPCT=0,DIC("W")="" I DO(2)["P" D WOV S MCPCT=+DO(2),MCPCTY=DIC G P
W ;
S MCPCT=$O(^DD(+DO(2),0,"ID",MCPCT)) S:MCPCT="" MCPCT=-1 I MCPCT+1 G WOV:$L(DIC("W"))+$L(^(MCPCT))>244 S:^(MCPCT)'="W """"" DIC("W")=DIC("W")_" W "" "" "_^(MCPCT) G W
S DIC("W")=$E(DIC("W"),2,999) Q
P I MCPCT,$D(^DD(MCPCT,.01,0)),$D(^DIC(+$P($P(^(0),U,2),"P",2),0))#2 S MCPCT=+$P(^(0),U,2),MCPCTW=$S($D(^(0,"GL")):^("GL"),1:"") D
.S:MCPCTW]"" DIC("W")=DIC("W")_" I '$D(DICR) S MCPCTY=+"_MCPCTY_"MCPCTY,0) I $D("_MCPCTW_"MCPCTY,0)) S MCPCTW="_MCPCT_",MCPCTZ="""_MCPCTW_""",MCPCTX=0 D WOV^MCARDCQ1"
Q
WOV S DIC("W")="S MCPCTW=+DO(2),MCPCTX=0,MCPCTY=Y,MCPCTZ=DIC D WOV^MCARDCQ1" Q
;
RENUM ;
D DO I '$D(DF),X?.NP,^DD(+DO(2),.01,0)["DINUM",@("$D("_MCARDC_"X))") S Y=X G 1^MCARDC
G F^MCARDC
;
WO W " " D WR I $D(DIC("W")),$D(@(DIC_"Y,0)")) W " " X DIC("W")
Q
;
WR D DO Q:DIC(0)["S"&(X'=" ")
I DO(2)["V" S MCPCTX=Y,DIYS=DIY D NAME^MCARDCM2 W DINAME S Y=MCPCTX,DIY=DIYS K DINAME,MCPCTX,DIYS Q
I +DIY'=DIY W DIY Q
I DO(2)["D" W:$E(DIY,4,5) +$E(DIY,4,5),"-" W:$E(DIY,6,7) +$E(DIY,6,7),"-" W DIY\10000+1700 W:DIY["." "@"_$E(DIY_0,9,10)_":"_$E(DIY_"000",11,12) Q
I DO(2)["P",$D(@("^"_$P(^DD(+DO(2),.01,0),"^",3)_+DIY_",0)")) S MCPCTX=Y,DIYS=DIY,Y=DIY,DJC=+DO(2) D Y^MCARDCM2 K DJC W Y S Y=MCPCTX,DIY=DIYS K DIYS Q
W DIY Q
;
Y ;
S DZ=Y,DD=$O(DS(DD)) S:DD="" DD=-1 S Y=+DS(DD),DICR(DD)=DS(DD),DIY=DIY(DD) W:DIC(0)["E" !?5,DD,?9,$P(X,U,'$D(DICRS))_$P(DS(DD),U,2,9) D WO:DIC(0)["E" S Y=DZ I DIC(0)["Y" G Y:DD<DS F Y=DS:-1 G Q^MCARDC:'Y S Y(+DS(Y))=""
;; ***ORIGINAL*** ;; G N:DIC(0)'["E" I DS>DD G Y:DD#5 W !,"TYPE '^' TO STOP, OR"
;; ***ORIGINAL*** ;; W !,"CHOOSE "_$O(DS(0))_"-"_DD R ": ",DIY:DTIME E D TIME G N
G N:DIC(0)'["E" I DS>DD G Y:DD#$S($D(DIC("W")):3,1:5) W !,"TYPE '^' TO STOP, OR "
W:DS'>DD ! W "CHOOSE "_$O(DS(0))_"-"_DD R ": ",DIY:DTIME E D TIME G N
I U[DIY S:DIY=U DUOUT=1 X DJCP G:DD=DS L^MCARDCM:DO(2)["O"&(DO(2)'["A"),A^MCARDC G Y^MCARDC:DIY="" S X=U G A^MCARDC
I +DIY'=DIY X DJCP S D=$S($D(DF):DF,1:"B"),X=DIY K DIY,DS G X^MCARDC
G BAD:'$D(DS(DIY)) S Y=+DS(DIY),DIY(+X)="" K DIC("W"),DIVP1 G C^MCARDC
;
TIME W *7 S DTOUT=1 Q
;
OK ;
S MCPCT=1 I $D(DS),DS=1 W !?9,"...OK" D YN^MCARDCN
I MCPCT>0 G R^MCARDC:MCPCT=1 S X=DIX X DJCP G L^MCARDCM
O I $D(DFAST)#2,X=DFAST S DFOUT=1 G N
BAD W:DIC(0)["Q" *7," ??" G A^MCARDC
N G NO^MCARDC
DS ;
I '$D(DISMN) S DISMN=1000 I $D(^DD("OS"))#2 S DISMN=$S(+$P(^DD("OS",^("OS"),0),U,2):$P(^(0),U,2),1:DISMN)
Q
;
MIX ;
S DID=D_"^-1",DID(1)=2,D=$P(DID,U) G IX^MCARDC
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCARDC1 3458 printed Jan 18, 2025@03:13:39 Page 2
MCARDC1 ;WISC/TJK-READ X, SET UP ID'S, ASK OK ;7/19/96 15:06
+1 ;;2.3;Medicine;;09/13/1996
+2 IF $DATA(DIC("A"))
SET DD=DIC("A")
GOTO B
+3 DO DO
SET Y=$PIECE(DO,"^",1)
IF D="B"
IF DO(2)>1.9
SET X=$PIECE(^DD(+DO(2),.01,0),"^",1)
IF X'[Y
IF Y'[X
SET Y=Y_" "_X
+4 SET DD="Select "_Y_": "
B IF $DATA(DIC("B"))
IF DIC("B")]""
SET Y=DIC("B")
SET X=$ORDER(@(DIC_"D,Y)"))
if X=""
SET X=-1
SET DIY=$SELECT($DATA(^(Y)):Y,$FIND(X,Y)-1=$LENGTH(Y):X,$DATA(@(DIC_"Y,0)")):$PIECE(^(0),U),1:Y)
WRITE DD
DO WR
READ "// ",X:DTIME
if X]""
GOTO DO
if '$TEST
GOTO TIME
SET X=DIY
if DIC(0)'["O"
SET DIC(0)=DIC(0)_"O"
GOTO DO
+1 WRITE DD
READ X:DTIME
IF '$TEST
if X=""
GOTO TIME
DO ;
+1 ; Naked references in DO+2 is the global in the variable DIC
+2 if $DATA(DO)
QUIT
IF $DATA(@(DIC_"0)"))
SET DO=^(0)
+3 IF '$TEST
SET DO="0^-1"
IF $DATA(DIC("P"))
SET DO=U_DIC("P")
SET ^(0)=DO
DO2 SET DO(2)=$PIECE(DO,"^",2)
IF DO?1"^".E
SET YMLH=$ORDER(^DD(+DO(2),0,"NM",0))
if YMLH=""
SET YMLH=-1
SET DO=YMLH_DO
+1 IF DO(2)["s"
IF $DATA(^DD(+DO(2),0,"SCR"))
SET DO("SCR")=^("SCR")
+2 if DO(2)'["I"!$DATA(DIC("W"))
QUIT
if '$DATA(^DD(+DO(2),0,"ID"))
QUIT
SET MCPCT=0
SET DIC("W")=""
IF DO(2)["P"
DO WOV
SET MCPCT=+DO(2)
SET MCPCTY=DIC
GOTO P
W ;
+1 SET MCPCT=$ORDER(^DD(+DO(2),0,"ID",MCPCT))
if MCPCT=""
SET MCPCT=-1
IF MCPCT+1
if $LENGTH(DIC("W"))+$LENGTH(^(MCPCT))>244
GOTO WOV
if ^(MCPCT)'="W """""
SET DIC("W")=DIC("W")_" W "" "" "_^(MCPCT)
GOTO W
+2 SET DIC("W")=$EXTRACT(DIC("W"),2,999)
QUIT
P IF MCPCT
IF $DATA(^DD(MCPCT,.01,0))
IF $DATA(^DIC(+$PIECE($PIECE(^(0),U,2),"P",2),0))#2
SET MCPCT=+$PIECE(^(0),U,2)
SET MCPCTW=$SELECT($DATA(^(0,"GL")):^("GL"),1:"")
Begin DoDot:1
+1 if MCPCTW]""
SET DIC("W")=DIC("W")_" I '$D(DICR) S MCPCTY=+"_MCPCTY_"MCPCTY,0) I $D("_MCPCTW_"MCPCTY,0)) S MCPCTW="_MCPCT_",MCPCTZ="""_MCPCTW_""",MCPCTX=0 D WOV^MCARDCQ1"
End DoDot:1
+2 QUIT
WOV SET DIC("W")="S MCPCTW=+DO(2),MCPCTX=0,MCPCTY=Y,MCPCTZ=DIC D WOV^MCARDCQ1"
QUIT
+1 ;
RENUM ;
+1 DO DO
IF '$DATA(DF)
IF X?.NP
IF ^DD(+DO(2),.01,0)["DINUM"
IF @("$D("_MCARDC_"X))")
SET Y=X
GOTO 1^MCARDC
+2 GOTO F^MCARDC
+3 ;
WO WRITE " "
DO WR
IF $DATA(DIC("W"))
IF $DATA(@(DIC_"Y,0)"))
WRITE " "
XECUTE DIC("W")
+1 QUIT
+2 ;
WR DO DO
if DIC(0)["S"&(X'=" ")
QUIT
+1 IF DO(2)["V"
SET MCPCTX=Y
SET DIYS=DIY
DO NAME^MCARDCM2
WRITE DINAME
SET Y=MCPCTX
SET DIY=DIYS
KILL DINAME,MCPCTX,DIYS
QUIT
+2 IF +DIY'=DIY
WRITE DIY
QUIT
+3 IF DO(2)["D"
if $EXTRACT(DIY,4,5)
WRITE +$EXTRACT(DIY,4,5),"-"
if $EXTRACT(DIY,6,7)
WRITE +$EXTRACT(DIY,6,7),"-"
WRITE DIY\10000+1700
if DIY["."
WRITE "@"_$EXTRACT(DIY_0,9,10)_":"_$EXTRACT(DIY_"000",11,12)
QUIT
+4 IF DO(2)["P"
IF $DATA(@("^"_$PIECE(^DD(+DO(2),.01,0),"^",3)_+DIY_",0)"))
SET MCPCTX=Y
SET DIYS=DIY
SET Y=DIY
SET DJC=+DO(2)
DO Y^MCARDCM2
KILL DJC
WRITE Y
SET Y=MCPCTX
SET DIY=DIYS
KILL DIYS
QUIT
+5 WRITE DIY
QUIT
+6 ;
Y ;
+1 SET DZ=Y
SET DD=$ORDER(DS(DD))
if DD=""
SET DD=-1
SET Y=+DS(DD)
SET DICR(DD)=DS(DD)
SET DIY=DIY(DD)
if DIC(0)["E"
WRITE !?5,DD,?9,$PIECE(X,U,'$DATA(DICRS))_$PIECE(DS(DD),U,2,9)
if DIC(0)["E"
DO WO
SET Y=DZ
IF DIC(0)["Y"
if DD<DS
GOTO Y
FOR Y=DS:-1
if 'Y
GOTO Q^MCARDC
SET Y(+DS(Y))=""
+2 ;; ***ORIGINAL*** ;; G N:DIC(0)'["E" I DS>DD G Y:DD#5 W !,"TYPE '^' TO STOP, OR"
+3 ;; ***ORIGINAL*** ;; W !,"CHOOSE "_$O(DS(0))_"-"_DD R ": ",DIY:DTIME E D TIME G N
+4 if DIC(0)'["E"
GOTO N
IF DS>DD
if DD#$SELECT($DATA(DIC("W")):3,1:5)
GOTO Y
WRITE !,"TYPE '^' TO STOP, OR "
+5 if DS'>DD
WRITE !
WRITE "CHOOSE "_$ORDER(DS(0))_"-"_DD
READ ": ",DIY:DTIME
IF '$TEST
DO TIME
GOTO N
+6 IF U[DIY
if DIY=U
SET DUOUT=1
XECUTE DJCP
if DD=DS
if DO(2)["O"&(DO(2)'["A")
GOTO L^MCARDCM
GOTO A^MCARDC
if DIY=""
GOTO Y^MCARDC
SET X=U
GOTO A^MCARDC
+7 IF +DIY'=DIY
XECUTE DJCP
SET D=$SELECT($DATA(DF):DF,1:"B")
SET X=DIY
KILL DIY,DS
GOTO X^MCARDC
+8 if '$DATA(DS(DIY))
GOTO BAD
SET Y=+DS(DIY)
SET DIY(+X)=""
KILL DIC("W"),DIVP1
GOTO C^MCARDC
+9 ;
TIME WRITE *7
SET DTOUT=1
QUIT
+1 ;
OK ;
+1 SET MCPCT=1
IF $DATA(DS)
IF DS=1
WRITE !?9,"...OK"
DO YN^MCARDCN
+2 IF MCPCT>0
if MCPCT=1
GOTO R^MCARDC
SET X=DIX
XECUTE DJCP
GOTO L^MCARDCM
O IF $DATA(DFAST)#2
IF X=DFAST
SET DFOUT=1
GOTO N
BAD if DIC(0)["Q"
WRITE *7," ??"
GOTO A^MCARDC
N GOTO NO^MCARDC
DS ;
+1 IF '$DATA(DISMN)
SET DISMN=1000
IF $DATA(^DD("OS"))#2
SET DISMN=$SELECT(+$PIECE(^DD("OS",^("OS"),0),U,2):$PIECE(^(0),U,2),1:DISMN)
+2 QUIT
+3 ;
MIX ;
+1 SET DID=D_"^-1"
SET DID(1)=2
SET D=$PIECE(DID,U)
GOTO IX^MCARDC
