MCARDCQ1 ;WISC/TJK-HELP FROM DIC (MODIFIED FOR MEDICINE SCREENS) ;8/23/96 10:06
;;2.3;Medicine;;09/13/1996
S Y=$S('$D(MCPCTY):0,MCPCTY:MCPCTY-.00000001,1:MCPCTY),DS=DS_X,X=-1 I DIZ S DIY=$L($P(DO,U,3))+DIY+5 S:Y="" Y=0
E S X=$S(Y=0:-1,1:Y),Y=0
D Y I $D(DIC("W")),$D(MCBDIC),DIX[MCBDIC_MCDF S DIY=" I $D("_DIC_"Y,0)) X:$D(DIC(""W"")) DIC(""W"")" S:$L(DS)+$L(DIY)<254 DS=DS_DIY S DIY=99
I $D(DIC("W")),'$D(MCBDIC) S DIY=" I $D("_DIC_"Y,0)) X:$D(DIC(""W"")) DIC(""W"")" S:$L(DS)+$L(DIY)<254 DS=DS_DIY S DIY=99
LST W !?3 S DD=DIY+3,MCMASS=1 I $Y>$S($G(DIC("W"))]"":18,1:21) R "Press <RETURN> to Continue, '^' to Quit: ",MCPCTY:DTIME X:MCPCTY'?1"^" DJCP Q:MCPCTY?1"^" W $C(13),$J("",15),$C(13),?3 G 0:MCPCTY?1P D Y ; DAD 7-17-96
;; ***ORIGINAL*** ;; LST W !?3 S DD=DIY+3,MCMASS=1 I $Y>20 R "Press <RETURN> to Continue, '^' to Quit: ",MCPCTY:DTIME X:MCPCTY'?1"^" DJCP Q:MCPCTY?1"^" W $C(13),$J("",15),$C(13),?3 G 0:MCPCTY?1P D Y
L X DIX I G 0
S DIW=$X X DS Q:$G(MCPCTY)=U I DIW-$X G LST:DD+DIY>79,LST:$Y>21 W ?DD S DD=DD+DIY
G L
;
WOV S MCPCTDIC=DIC,DIC=MCPCTZ,MCPCTWW=Y,Y=MCPCTY
W1 S MCPCTX=$O(^DD(MCPCTW,0,"ID",MCPCTX)) I MCPCTX]"" S MCPCT=^(MCPCTX) X "W "" "",$E("_MCPCTZ_MCPCTY_",0),0)",MCPCT G W1
S DIC=MCPCTDIC,Y=MCPCTWW K MCPCTDIC,MCPCTW,MCPCTX,MCPCTWW,MCPCTZ Q
;
Y ;I $D(^("OS",^DD("OS"),"XY")) S DIZ=^("XY") I DIZ?1U.E S (IOX,IOY)=0 X DIZ K IOX,IOY
S DIZ=$Y+21
Q
CONT S MCMASS=1
I $G(MCPCTY)'=U R !," Press <RETURN> to Continue, '^' to Quit: ",MCPCTY:DTIME
Q
;
S S DS(1)=X,DS(2)=Y I 1 X:$D(DIC("S")) DIC("S")
I $T S Y=DS(2) D SCR:$D(DO("SCR"))
S X=DS(1),Y=DS(2)
IF D I 1 ; clear bottom of screen if necessary
. IF $Y>21 D
.. D CONT
.. I MCPCTY'=U X DJCP
.. Q
. ;END IF
. ;
. Q
;END IF
;
Q
;
SCR I @("$D("_DIC_"Y,0))") X DO("SCR")
Q
;
DT W:$E(MCPCT,4,5) +$E(MCPCT,4,5)_"-" W:$E(MCPCT,6,7) +$E(MCPCT,6,7)_"-" W $E(MCPCT,1,3)+1700 W:MCPCT["." " ("_$E(MCPCT_0,9,10)_":"_$E(MCPCT_"000",11,12)_")" Q
;
0 ;
K DIW,DIZ,DS Q:DIC(0)'["L" S XQH=-1 I $D(MCPCTY) S:MCPCTY="??" DZ=MCPCTY S:MCPCTY?1P DZ="?"
I $S($D(DLAYGO):DO(2)\1-DLAYGO,1:1),$D(^DIC(+DO(2),0,"LAYGO")),DUZ(0)'="@" F X=1:1 S Y=$E(^("LAYGO"),X) I DUZ(0)[Y G RCR:Y="" Q
;
;I $D(DZ)#2,DZ="?" W:$X>3 ! W ?3,"YOU MAY ENTER A NEW ",$P(DO,U,1),", IF YOU WISH" D CONT Q:MCPCTY=U
;I X DJCP F DG=3,12 I $D(^DD(+DO(2),.01,DG)) S X=^(DG) F MCPCT=$L(X," "):-1:1 I $L($P(X," ",1,MCPCT))<70 W !?5,$P(X," ",1,MCPCT) W:MCPCT'=$L(X," ") !?5,$P(X," ",MCPCT+1,99) Q
I $D(DZ)#2,DZ="?" D Q:MCPCTY=U
. W:$X>3 ! W ?3,"YOU MAY ENTER A NEW ",$P(DO,U,1),", IF YOU WISH"
. D CONT Q:MCPCTY=U X DJCP
. F DG=3,12 I $D(^DD(+DO(2),.01,DG)) S X=^(DG) F MCPCT=$L(X," "):-1:1 I $L($P(X," ",1,MCPCT))<70 W !?5,$P(X," ",1,MCPCT) W:MCPCT'=$L(X," ") !?5,$P(X," ",MCPCT+1,99) Q
. D CONT Q:MCPCTY=U X DJCP
. Q
;
S DZ1=DO(2),DZ1(0)=DIC(0),DZ1(1)=DO
I $D(^DD(+DO(2),.01,4)) X ^(4)
IF $G(DZ)?1"??".E D
. IF $D(^DD(+DO(2),.01,22)) D
.. S XQH=^DD(+DO(2),.01,22)
.. D EN1^XQH
.. Q
. ;END IF
. ;
. IF XQH=-1,$D(^DD(+DZ1,.01,21)) D
.. ;IF $P(^DD(+DZ1,.01,21,0),"^",4)+$Y>21 D
..;. D CONT
..;. I MCPCTY'=U X DJCP
..;. Q
.. ;END IF
.. ;
.. I $G(MCPCTY)'=U D D CONT X DJCP
... S X=0
... F S X=$O(^DD(+DZ1,.01,21,X)) Q:X'>0 W !,$G(^(X,0)) I $Y>21 D CONT Q:MCPCTY=U X DJCP
... Q
.. Q
. ;END IF
. ;
. Q
;END IF
;
I $G(MCPCTY)=U Q
S DO(2)=$S(DJ4["S":DJ4,1:DZ1),DIC(0)=DZ1(0),DO=DZ1(1) K DZ1
I $Y>20 D CONT Q:MCPCTY=U X DJCP
I $D(DZ),DO(2)["S" W !,"CHOOSE FROM: " F X=1:1 S Y=$P($P(^DD(+DO(2),.01,0),U,3),";",X) D CONT:Y="" Q:Y="" W !?7,$P(Y,":",1),?15," ",$P(Y,":",2) I $Y>21,$P($P(^(0),U,3),";",X+1)'="" D CONT Q:MCPCTY=U X DJCP
I DO(2)["V" S DU=+DO(2),D=.01 D V
RCR Q:DO(2)'["P"!$D(DZ(1)) S DZ(1)=DIC,DZ(0)=DIC(0),DS=^DD(+DO(2),.01,0),DIC=U_$P(DS,U,3),DIC(0)=$E("L",$P(DS,U,2)'["'")
F Y=1:1:3 S X=$E("VWS",Y) S:$D(DIC(X)) DZ(X)=DIC(X) K DO K:Y<3!'DS DIC(X)
K:DS DZ(3) D DQ^MCARDCQ K DICW,DICS S DIC=DZ(1),DIC(0)=DZ(0) F Y=1:1:3 S X=$E("VWS",Y) K DO,DIC(X) S:$D(DZ(Y)) DIC(X)=DZ(Y)
D CONT
Q
V W:$X ! W ?5,"Enter one of the following:",!?7
F Y=0:0 S Y=$O(^DD(DU,D,"V",Y)) S:Y="" Y=-1 Q:Y'>0 I $D(^(Y,0)) S Y(0)=^(0) X:$D(DIC("V")) DIC("V") I W:$D(^DIC(+Y(0),0)) $P(Y(0),U,4)_".EntryName to select a "_$P(Y(0),U,2),!?7
W !?5,"To see the entries in any particular file, type <Prefix.?>",! S DU="" I DZ'?1"??".E K X,DZ Q
T F DG=2:1 S X=$T(T+DG) Q:X="" W !?5,$E(X,4,99)
K X,DZ Q
;;If you simply enter the name then the system will search each of
;;the above files for the name you have entered. If a match is
;;found the system will ask you if it is the entry that you desire.
;;
;;However, if you know the file name of the entry you want
;;then you can speed up processing by using the following
;;syntax to choose the entry:
;; <Prefix>.<entry name>
;; or
;; <Message>.<entry name>
;; or
;; <File Name>.<entry name>
;;
;;Also, you do NOT need to enter the entire file name or message
;;to direct the look up. Using the first few characters will
;;be enough information.
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCARDCQ1 5225 printed Oct 16, 2024@18:13:12 Page 2
MCARDCQ1 ;WISC/TJK-HELP FROM DIC (MODIFIED FOR MEDICINE SCREENS) ;8/23/96 10:06
+1 ;;2.3;Medicine;;09/13/1996
+2 SET Y=$SELECT('$DATA(MCPCTY):0,MCPCTY:MCPCTY-.00000001,1:MCPCTY)
SET DS=DS_X
SET X=-1
IF DIZ
SET DIY=$LENGTH($PIECE(DO,U,3))+DIY+5
if Y=""
SET Y=0
+3 IF '$TEST
SET X=$SELECT(Y=0:-1,1:Y)
SET Y=0
+4 DO Y
IF $DATA(DIC("W"))
IF $DATA(MCBDIC)
IF DIX[MCBDIC_MCDF
SET DIY=" I $D("_DIC_"Y,0)) X:$D(DIC(""W"")) DIC(""W"")"
if $LENGTH(DS)+$LENGTH(DIY)<254
SET DS=DS_DIY
SET DIY=99
+5 IF $DATA(DIC("W"))
IF '$DATA(MCBDIC)
SET DIY=" I $D("_DIC_"Y,0)) X:$D(DIC(""W"")) DIC(""W"")"
if $LENGTH(DS)+$LENGTH(DIY)<254
SET DS=DS_DIY
SET DIY=99
LST ; DAD 7-17-96
WRITE !?3
SET DD=DIY+3
SET MCMASS=1
IF $Y>$SELECT($GET(DIC("W"))]"":18,1:21)
READ "Press <RETURN> to Continue, '^' to Quit: ",MCPCTY:DTIME
if MCPCTY'?1"^"
XECUTE DJCP
if MCPCTY?1"^"
QUIT
WRITE $CHAR(13),$JUSTIFY("",15),$CHAR(13),?3
if MCPCTY?1P
GOTO 0
DO Y
+1 ;; ***ORIGINAL*** ;; LST W !?3 S DD=DIY+3,MCMASS=1 I $Y>20 R "Press <RETURN> to Continue, '^' to Quit: ",MCPCTY:DTIME X:MCPCTY'?1"^" DJCP Q:MCPCTY?1"^" W $C(13),$J("",15),$C(13),?3 G 0:MCPCTY?1P D Y
L XECUTE DIX
IF $TEST
GOTO 0
+1 SET DIW=$X
XECUTE DS
if $GET(MCPCTY)=U
QUIT
IF DIW-$X
if DD+DIY>79
GOTO LST
if $Y>21
GOTO LST
WRITE ?DD
SET DD=DD+DIY
+2 GOTO L
+3 ;
WOV SET MCPCTDIC=DIC
SET DIC=MCPCTZ
SET MCPCTWW=Y
SET Y=MCPCTY
W1 SET MCPCTX=$ORDER(^DD(MCPCTW,0,"ID",MCPCTX))
IF MCPCTX]""
SET MCPCT=^(MCPCTX)
XECUTE "W "" "",$E("_MCPCTZ_MCPCTY_",0),0)"
XECUTE MCPCT
GOTO W1
+1 SET DIC=MCPCTDIC
SET Y=MCPCTWW
KILL MCPCTDIC,MCPCTW,MCPCTX,MCPCTWW,MCPCTZ
QUIT
+2 ;
Y ;I $D(^("OS",^DD("OS"),"XY")) S DIZ=^("XY") I DIZ?1U.E S (IOX,IOY)=0 X DIZ K IOX,IOY
+1 SET DIZ=$Y+21
+2 QUIT
CONT SET MCMASS=1
+1 IF $GET(MCPCTY)'=U
READ !," Press <RETURN> to Continue, '^' to Quit: ",MCPCTY:DTIME
+2 QUIT
+3 ;
S SET DS(1)=X
SET DS(2)=Y
IF 1
if $DATA(DIC("S"))
XECUTE DIC("S")
+1 IF $TEST
SET Y=DS(2)
if $DATA(DO("SCR"))
DO SCR
+2 SET X=DS(1)
SET Y=DS(2)
+3 ; clear bottom of screen if necessary
IF $TEST
Begin DoDot:1
+4 IF $Y>21
Begin DoDot:2
+5 DO CONT
+6 IF MCPCTY'=U
XECUTE DJCP
+7 QUIT
End DoDot:2
+8 ;END IF
+9 ;
+10 QUIT
End DoDot:1
IF 1
+11 ;END IF
+12 ;
+13 QUIT
+14 ;
SCR IF @("$D("_DIC_"Y,0))")
XECUTE DO("SCR")
+1 QUIT
+2 ;
DT if $EXTRACT(MCPCT,4,5)
WRITE +$EXTRACT(MCPCT,4,5)_"-"
if $EXTRACT(MCPCT,6,7)
WRITE +$EXTRACT(MCPCT,6,7)_"-"
WRITE $EXTRACT(MCPCT,1,3)+1700
if MCPCT["."
WRITE " ("_$EXTRACT(MCPCT_0,9,10)_":"_$EXTRACT(MCPCT_"000",11,12)_")"
QUIT
+1 ;
0 ;
+1 KILL DIW,DIZ,DS
if DIC(0)'["L"
QUIT
SET XQH=-1
IF $DATA(MCPCTY)
if MCPCTY="??"
SET DZ=MCPCTY
if MCPCTY?1P
SET DZ="?"
+2 IF $SELECT($DATA(DLAYGO):DO(2)\1-DLAYGO,1:1)
IF $DATA(^DIC(+DO(2),0,"LAYGO"))
IF DUZ(0)'="@"
FOR X=1:1
SET Y=$EXTRACT(^("LAYGO"),X)
IF DUZ(0)[Y
if Y=""
GOTO RCR
QUIT
+3 ;
+4 ;I $D(DZ)#2,DZ="?" W:$X>3 ! W ?3,"YOU MAY ENTER A NEW ",$P(DO,U,1),", IF YOU WISH" D CONT Q:MCPCTY=U
+5 ;I X DJCP F DG=3,12 I $D(^DD(+DO(2),.01,DG)) S X=^(DG) F MCPCT=$L(X," "):-1:1 I $L($P(X," ",1,MCPCT))<70 W !?5,$P(X," ",1,MCPCT) W:MCPCT'=$L(X," ") !?5,$P(X," ",MCPCT+1,99) Q
+6 IF $DATA(DZ)#2
IF DZ="?"
Begin DoDot:1
+7 if $X>3
WRITE !
WRITE ?3,"YOU MAY ENTER A NEW ",$PIECE(DO,U,1),", IF YOU WISH"
+8 DO CONT
if MCPCTY=U
QUIT
XECUTE DJCP
+9 FOR DG=3,12
IF $DATA(^DD(+DO(2),.01,DG))
SET X=^(DG)
FOR MCPCT=$LENGTH(X," "):-1:1
IF $LENGTH($PIECE(X," ",1,MCPCT))<70
WRITE !?5,$PIECE(X," ",1,MCPCT)
if MCPCT'=$LENGTH(X," ")
WRITE !?5,$PIECE(X," ",MCPCT+1,99)
QUIT
+10 DO CONT
if MCPCTY=U
QUIT
XECUTE DJCP
+11 QUIT
End DoDot:1
if MCPCTY=U
QUIT
+12 ;
+13 SET DZ1=DO(2)
SET DZ1(0)=DIC(0)
SET DZ1(1)=DO
+14 IF $DATA(^DD(+DO(2),.01,4))
XECUTE ^(4)
+15 IF $GET(DZ)?1"??".E
Begin DoDot:1
+16 IF $DATA(^DD(+DO(2),.01,22))
Begin DoDot:2
+17 SET XQH=^DD(+DO(2),.01,22)
+18 DO EN1^XQH
+19 QUIT
End DoDot:2
+20 ;END IF
+21 ;
+22 IF XQH=-1
IF $DATA(^DD(+DZ1,.01,21))
Begin DoDot:2
+23 ;IF $P(^DD(+DZ1,.01,21,0),"^",4)+$Y>21 D
+24 ;. D CONT
+25 ;. I MCPCTY'=U X DJCP
+26 ;. Q
+27 ;END IF
+28 ;
+29 IF $GET(MCPCTY)'=U
Begin DoDot:3
+30 SET X=0
+31 FOR
SET X=$ORDER(^DD(+DZ1,.01,21,X))
if X'>0
QUIT
WRITE !,$GET(^(X,0))
IF $Y>21
DO CONT
if MCPCTY=U
QUIT
XECUTE DJCP
+32 QUIT
End DoDot:3
DO CONT
XECUTE DJCP
+33 QUIT
End DoDot:2
+34 ;END IF
+35 ;
+36 QUIT
End DoDot:1
+37 ;END IF
+38 ;
+39 IF $GET(MCPCTY)=U
QUIT
+40 SET DO(2)=$SELECT(DJ4["S":DJ4,1:DZ1)
SET DIC(0)=DZ1(0)
SET DO=DZ1(1)
KILL DZ1
+41 IF $Y>20
DO CONT
if MCPCTY=U
QUIT
XECUTE DJCP
+42 IF $DATA(DZ)
IF DO(2)["S"
WRITE !,"CHOOSE FROM: "
FOR X=1:1
SET Y=$PIECE($PIECE(^DD(+DO(2),.01,0),U,3),";",X)
if Y=""
DO CONT
if Y=""
QUIT
WRITE !?7,$PIECE(Y,":",1),?15," ",$PIECE(Y,":",2)
IF $Y>21
IF $PIECE($PIECE(^(0),U,3),";",X+1)'=""
DO CONT
if MCPCTY=U
QUIT
XECUTE DJCP
+43 IF DO(2)["V"
SET DU=+DO(2)
SET D=.01
DO V
RCR if DO(2)'["P"!$DATA(DZ(1))
QUIT
SET DZ(1)=DIC
SET DZ(0)=DIC(0)
SET DS=^DD(+DO(2),.01,0)
SET DIC=U_$PIECE(DS,U,3)
SET DIC(0)=$EXTRACT("L",$PIECE(DS,U,2)'["'")
+1 FOR Y=1:1:3
SET X=$EXTRACT("VWS",Y)
if $DATA(DIC(X))
SET DZ(X)=DIC(X)
KILL DO
if Y<3!'DS
KILL DIC(X)
+2 if DS
KILL DZ(3)
DO DQ^MCARDCQ
KILL DICW,DICS
SET DIC=DZ(1)
SET DIC(0)=DZ(0)
FOR Y=1:1:3
SET X=$EXTRACT("VWS",Y)
KILL DO,DIC(X)
if $DATA(DZ(Y))
SET DIC(X)=DZ(Y)
+3 DO CONT
+4 QUIT
V if $X
WRITE !
WRITE ?5,"Enter one of the following:",!?7
+1 FOR Y=0:0
SET Y=$ORDER(^DD(DU,D,"V",Y))
if Y=""
SET Y=-1
if Y'>0
QUIT
IF $DATA(^(Y,0))
SET Y(0)=^(0)
if $DATA(DIC("V"))
XECUTE DIC("V")
IF $TEST
if $DATA(^DIC(+Y(0),0))
WRITE $PIECE(Y(0),U,4)_".EntryName to select a "_$PIECE(Y(0),U,2),!?7
+2 WRITE !?5,"To see the entries in any particular file, type <Prefix.?>",!
SET DU=""
IF DZ'?1"??".E
KILL X,DZ
QUIT
T FOR DG=2:1
SET X=$TEXT(T+DG)
if X=""
QUIT
WRITE !?5,$EXTRACT(X,4,99)
+1 KILL X,DZ
QUIT
+2 ;;If you simply enter the name then the system will search each of
+3 ;;the above files for the name you have entered. If a match is
+4 ;;found the system will ask you if it is the entry that you desire.
+5 ;;
+6 ;;However, if you know the file name of the entry you want
+7 ;;then you can speed up processing by using the following
+8 ;;syntax to choose the entry:
+9 ;; <Prefix>.<entry name>
+10 ;; or
+11 ;; <Message>.<entry name>
+12 ;; or
+13 ;; <File Name>.<entry name>
+14 ;;
+15 ;;Also, you do NOT need to enter the entire file name or message
+16 ;;to direct the look up. Using the first few characters will
+17 ;;be enough information.
