- 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.
- 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">L">L">L(X," "):-1:1 I $L">L">L">L($P(X," ",1,MCPCT))<70 W !?5,$P(X," ",1,MCPCT) W:MCPCT'=$L">L">L">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.