- MCARDNQ ;WISC/TJK,JA-SCREEN INPUT - QUESTIONMARKS ;8/23/96 08:08
- ;;2.3;Medicine;;09/13/1996
- S D=""
- A S DJX="" X DJCP
- I DJ4["R" W "**REQUIRED**",*7
- S:'$D(X) X=DJXX G:X'="??" F G:'$D(^DD(DJDD,DJAT,21,0)) F G:'$P(^(0),U,4) F
- S DJZ1=0,DIWL=1,DIWR=79,DIWF="" K ^UTILITY($J,"W")
- S DJXX=X F DJK=1:1 S DJZ1=$O(^DD(DJDD,DJAT,21,DJZ1)) Q:DJZ1="" S X=^(DJZ1,0) D ^DIWP
- D ^DIWW ; purge WP buffer
- S DJZ1=0 F DJK=1:1 S DJZ1=$O(^UTILITY($J,"W",DIWL,DJZ1)) Q:DJZ1="" D:$Y>21 CONT Q:DJX[U W !,^(DJZ1,0)
- K DJZ1,DJK,^UTILITY($J,"W",DIWL),DIWL,DIWR,DIWF S X=DJXX G:DJX'[U F Q
- CONT D MCMASS W !,"Press <RETURN> to Continue, '^' to Quit: " R DJX:DTIME X DJCP W ! Q
- F D MCMASS D:$Y>21 CONT Q:DJX[U D:$D(^DD(DJDD,DJAT,3)) MCDJHELP I $D(^DD(DJDD,DJAT,4)) W ! X ^(4)
- ;I DJ4["S",DJ4'["M" D:$Y>21 CONT Q:DJX[U W !,"CHOOSE FROM:" S DJS=$P(^DD(DJDD,DJAT,0),U,3) F DJK=1:1 S Y=$P(DJS,";",DJK) Q:Y="" S Y="'"_$P(Y,":",1)_"' FOR "_$P(Y,":",2) D:$Y>21 CONT Q:DJX[U W !,Y
- ;
- I DJ4["S",DJ4'["M" D:$Y>21 CONT Q:DJX[U D
- . N DIC,DJX S DIC("S")=$G(^DD(DJDD,DJAT,12.1)),DJX=""
- . W !,"CHOOSE FROM:"
- . S DJS=$P(^DD(DJDD,DJAT,0),U,3)
- . F DJK=1:1 S Y=$P(DJS,";",DJK) Q:Y=""!(DJX[U) D
- .. I DIC("S")]"" S Y=$P(Y,":") X DIC("S") Q:'$T S Y=$P(DJS,";",DJK)
- .. S Y="'"_$P(Y,":",1)_"' FOR "_$P(Y,":",2)
- .. D:$Y>21 CONT Q:DJX[U
- .. W !,Y
- .. Q
- . Q
- ;
- D DCS
- I DJ4["P" K DIC("S") S DJDIC=DIC,DJD0=D0,DIC(0)=$S(DJ4["'":"MEQZ",1:"MEQZL"),DIC=+$P(DJ4,"P",2) D:$Y>21 CONT X:$P(^DD(DJDD,DJAT,0),U,2)["*" ^(12.1) D ^MCARDC K DIC S DIC=DJDIC,D0=DJD0 G:Y<0 R1 S V(V)=$P(Y,U,2) G P1
- ;I DJ4["D" S:'$D(%DT) %DT="E" D HELP
- I DJ4["D" D
- . N %DT,X,Y
- . I 'DJ4 S Y=$P($P(DJ0,U,5,99)," D ^%DT")
- . I DJ4 S Y=$P($P($G(^DD(+DJ4,.01,0)),U,5,99)," D ^%DT")
- . X $S(Y]"":Y,1:"S %DT=""E""")
- . D HELP
- . Q
- K DJS,DJZ1 I $Y>23 X DJCL R "Press <RETURN> to Continue",X:DTIME S DJZ=V D N^MCARDPL S V=DJZ Q
- S @$P(DJJ(V),U,2) X XY W $G(V(V)) Q
- P D DCS,MCMASS
- K DIC("S") S DJDIC=DIC,DJD0=D0,DIC(0)=$S(DJ4["'":"MEQZ",1:"MEQZL"),DIC=+$P(DJ4,"P",2) X DJCP X:$P(^DD(DJDD,DJAT,0),U,2)["*" ^(12.1) D ^MCARDC K DIC S:+Y>0 V(V)=$E($P(Y,U,2),1,+DJJ(V)),DIC=DJDIC,D0=DJD0 G:Y<0 R1
- P1 S X=+Y,V(V)=$E($P(Y,U,2),1,+DJJ(V)),(DIE,DIC)=DJDIC,DA=DJDN,DR=DJ3_"////"_X X DJCP W ! D ^DIE S D0=DJD0 K DJD0 D PP S V(V)=$E(V(V),1,+DJJ(V))
- S YMLH=$O(^MCAR(697.3,DJN,1,"A",V,0)) S:YMLH="" YMLH=-1
- X:$D(^MCAR(697.3,DJN,1,YMLH,1)) ^(1)
- I $Y>23 S DJZ=V D N^MCARDPL S V=DJZ Q
- S DY=17,DX=0 X XY W DJEOP S @$P(DJJ(V),U,2) X XY W DJHIN X XY W V(V),DJLIN Q
- R1 K DJD0 S DIC=DJDIC D MCMASS
- S @$P(DJJ(V),U,2) X XY W:$D(V(V)) DJHIN W:$D(V(V)) V(V) X XY Q
- HELP ;
- D MCMASS
- D:$Y>21 R W !,"EXAMPLES OF VALID DATES:"
- D:$Y>21 R W !," JAN 22 1957 or 22 JAN 57 or 1/22/57 or 012257"
- D:$Y>21 R W !," T (FOR TODAY), T+1 (FOR TOMORROW), T+2, T+7, etc."," T-1 (FOR YESTERDAY)"
- D:$Y>21 R W !," T-3W (3 WEEKS AGO), etc."
- D:$Y>21 R W !,"IF THE YEAR IS OMITTED, THE COMPUTER USES THE CURRENT YEAR"
- D:$Y>21 R I %DT'["X" W !,"YOU MAY OMIT THE PRECISE DAY, AS: JAN, 1957",!
- D:$Y>21 R I %DT["T" W !,"FOLLOW DATE WITH TIME, AS: JAN 22@10, T@10PM, ETC."
- D R
- Q
- R D MCMASS X DJCL W "Press <RETURN> to Continue" R DJX:10 X DJCP
- PP D MCMASS S DJZ=+$P($P(^DD(DJDD,DJAT,0),"^",2),"P",2) Q:$P(^DD(DJZ,.01,0),"^",2)'["P"
- P11 I $D(@("^"_$P(^DD(DJZ,.01,0),U,3)_"V(V),0)")) S V(V)=$P(^(0),U,1)
- S DJZ=+$P($P(^DD(DJZ,.01,0),"^",2),"P",2) Q:$P(^DD(DJZ,.01,0),"^",2)'["P" G P11
- DCS S DJNODE=.01 Q:DJ4'["P"
- S DJ44=$S(DJ4'["'":DJ4,1:$P(DJ4,"P",2))
- Q:'$D(^DD(+DJ44,0,"UP")) I $D(^DD(^DD(+DJ44,0,"UP"),0,"UP")) S DJ44=^DD(+DJ44,0,"UP"),DJNODE=$P(DJJ(V),U,3)
- I DJNODE=.01,$D(^DD(DJDD,DJ3,12.1)) X ^(12.1) G DCS1
- K DIC("S") Q:'$D(^DD(+DJ44,DJNODE)) S:'$D(DIC(0)) DIC(0)=""
- I $D(^DD(+DJ44,DJNODE,12.1)) X ^(12.1)
- E K DJNODE,DJ44 Q
- DCS1 S:'$D(DIC(0)) DIC(0)="" K:DIC(0)'="" DIC("S") K DJNODE,DJ44 Q
- MCDJHELP ;
- S MCCNT=0,MCDJHELP(1)=^DD(DJDD,DJAT,3)
- D MCDJHEL1
- R !,"Press <RETURN> to Continue: ",MCXRET:DTIME
- X DJCP
- K MCDJHELP,MCCNT,MCXRET
- Q
- MCDJHEL1 ;
- S MCCNT=MCCNT+1
- Q:'$D(MCDJHELP(MCCNT))
- F I=79:-1:1 Q:$E(MCDJHELP(MCCNT),I)=" "
- I $L(MCDJHELP(MCCNT))>79 S MCDJHELP(MCCNT+1)=$E(MCDJHELP(MCCNT),I+1,$L(MCDJHELP(MCCNT))),MCDJHELP(MCCNT)=$E(MCDJHELP(MCCNT),1,I-1)
- W !,MCDJHELP(MCCNT)
- G MCDJHEL1
- MCMASS ;Let the Screen Handlers know that the command was erase.
- S MCMASS=1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCARDNQ 4384 printed Feb 18, 2025@23:39:09 Page 2
- MCARDNQ ;WISC/TJK,JA-SCREEN INPUT - QUESTIONMARKS ;8/23/96 08:08
- +1 ;;2.3;Medicine;;09/13/1996
- +2 SET D=""
- A SET DJX=""
- XECUTE DJCP
- +1 IF DJ4["R"
- WRITE "**REQUIRED**",*7
- +2 if '$DATA(X)
- SET X=DJXX
- if X'="??"
- GOTO F
- if '$DATA(^DD(DJDD,DJAT,21,0))
- GOTO F
- if '$PIECE(^(0),U,4)
- GOTO F
- +3 SET DJZ1=0
- SET DIWL=1
- SET DIWR=79
- SET DIWF=""
- KILL ^UTILITY($JOB,"W")
- +4 SET DJXX=X
- FOR DJK=1:1
- SET DJZ1=$ORDER(^DD(DJDD,DJAT,21,DJZ1))
- if DJZ1=""
- QUIT
- SET X=^(DJZ1,0)
- DO ^DIWP
- +5 ; purge WP buffer
- DO ^DIWW
- +6 SET DJZ1=0
- FOR DJK=1:1
- SET DJZ1=$ORDER(^UTILITY($JOB,"W",DIWL,DJZ1))
- if DJZ1=""
- QUIT
- if $Y>21
- DO CONT
- if DJX[U
- QUIT
- WRITE !,^(DJZ1,0)
- +7 KILL DJZ1,DJK,^UTILITY($JOB,"W",DIWL),DIWL,DIWR,DIWF
- SET X=DJXX
- if DJX'[U
- GOTO F
- QUIT
- CONT DO MCMASS
- WRITE !,"Press <RETURN> to Continue, '^' to Quit: "
- READ DJX:DTIME
- XECUTE DJCP
- WRITE !
- QUIT
- F DO MCMASS
- if $Y>21
- DO CONT
- if DJX[U
- QUIT
- if $DATA(^DD(DJDD,DJAT,3))
- DO MCDJHELP
- IF $DATA(^DD(DJDD,DJAT,4))
- WRITE !
- XECUTE ^(4)
- +1 ;I DJ4["S",DJ4'["M" D:$Y>21 CONT Q:DJX[U W !,"CHOOSE FROM:" S DJS=$P(^DD(DJDD,DJAT,0),U,3) F DJK=1:1 S Y=$P(DJS,";",DJK) Q:Y="" S Y="'"_$P(Y,":",1)_"' FOR "_$P(Y,":",2) D:$Y>21 CONT Q:DJX[U W !,Y
- +2 ;
- +3 IF DJ4["S"
- IF DJ4'["M"
- if $Y>21
- DO CONT
- if DJX[U
- QUIT
- Begin DoDot:1
- +4 NEW DIC,DJX
- SET DIC("S")=$GET(^DD(DJDD,DJAT,12.1))
- SET DJX=""
- +5 WRITE !,"CHOOSE FROM:"
- +6 SET DJS=$PIECE(^DD(DJDD,DJAT,0),U,3)
- +7 FOR DJK=1:1
- SET Y=$PIECE(DJS,";",DJK)
- if Y=""!(DJX[U)
- QUIT
- Begin DoDot:2
- +8 IF DIC("S")]""
- SET Y=$PIECE(Y,":")
- XECUTE DIC("S")
- if '$TEST
- QUIT
- SET Y=$PIECE(DJS,";",DJK)
- +9 SET Y="'"_$PIECE(Y,":",1)_"' FOR "_$PIECE(Y,":",2)
- +10 if $Y>21
- DO CONT
- if DJX[U
- QUIT
- +11 WRITE !,Y
- +12 QUIT
- End DoDot:2
- +13 QUIT
- End DoDot:1
- +14 ;
- +15 DO DCS
- +16 IF DJ4["P"
- KILL DIC("S")
- SET DJDIC=DIC
- SET DJD0=D0
- SET DIC(0)=$SELECT(DJ4["'":"MEQZ",1:"MEQZL")
- SET DIC=+$PIECE(DJ4,"P",2)
- if $Y>21
- DO CONT
- if $PIECE(^DD(DJDD,DJAT,0),U,2)["*"
- XECUTE ^(12.1)
- DO ^MCARDC
- KILL DIC
- SET DIC=DJDIC
- SET D0=DJD0
- if Y<0
- GOTO R1
- SET V(V)=$PIECE(Y,U,2)
- GOTO P1
- +17 ;I DJ4["D" S:'$D(%DT) %DT="E" D HELP
- +18 IF DJ4["D"
- Begin DoDot:1
- +19 NEW %DT,X,Y
- +20 IF 'DJ4
- SET Y=$PIECE($PIECE(DJ0,U,5,99)," D ^%DT")
- +21 IF DJ4
- SET Y=$PIECE($PIECE($GET(^DD(+DJ4,.01,0)),U,5,99)," D ^%DT")
- +22 XECUTE $SELECT(Y]"":Y,1:"S %DT=""E""")
- +23 DO HELP
- +24 QUIT
- End DoDot:1
- +25 KILL DJS,DJZ1
- IF $Y>23
- XECUTE DJCL
- READ "Press <RETURN> to Continue",X:DTIME
- SET DJZ=V
- DO N^MCARDPL
- SET V=DJZ
- QUIT
- +26 SET @$PIECE(DJJ(V),U,2)
- XECUTE XY
- WRITE $GET(V(V))
- QUIT
- P DO DCS
- DO MCMASS
- +1 KILL DIC("S")
- SET DJDIC=DIC
- SET DJD0=D0
- SET DIC(0)=$SELECT(DJ4["'":"MEQZ",1:"MEQZL")
- SET DIC=+$PIECE(DJ4,"P",2)
- XECUTE DJCP
- if $PIECE(^DD(DJDD,DJAT,0),U,2)["*"
- XECUTE ^(12.1)
- DO ^MCARDC
- KILL DIC
- if +Y>0
- SET V(V)=$EXTRACT($PIECE(Y,U,2),1,+DJJ(V))
- SET DIC=DJDIC
- SET D0=DJD0
- if Y<0
- GOTO R1
- P1 SET X=+Y
- SET V(V)=$EXTRACT($PIECE(Y,U,2),1,+DJJ(V))
- SET (DIE,DIC)=DJDIC
- SET DA=DJDN
- SET DR=DJ3_"////"_X
- XECUTE DJCP
- WRITE !
- DO ^DIE
- SET D0=DJD0
- KILL DJD0
- DO PP
- SET V(V)=$EXTRACT(V(V),1,+DJJ(V))
- +1 SET YMLH=$ORDER(^MCAR(697.3,DJN,1,"A",V,0))
- if YMLH=""
- SET YMLH=-1
- +2 if $DATA(^MCAR(697.3,DJN,1,YMLH,1))
- XECUTE ^(1)
- +3 IF $Y>23
- SET DJZ=V
- DO N^MCARDPL
- SET V=DJZ
- QUIT
- +4 SET DY=17
- SET DX=0
- XECUTE XY
- WRITE DJEOP
- SET @$PIECE(DJJ(V),U,2)
- XECUTE XY
- WRITE DJHIN
- XECUTE XY
- WRITE V(V),DJLIN
- QUIT
- R1 KILL DJD0
- SET DIC=DJDIC
- DO MCMASS
- +1 SET @$PIECE(DJJ(V),U,2)
- XECUTE XY
- if $DATA(V(V))
- WRITE DJHIN
- if $DATA(V(V))
- WRITE V(V)
- XECUTE XY
- QUIT
- HELP ;
- +1 DO MCMASS
- +2 if $Y>21
- DO R
- WRITE !,"EXAMPLES OF VALID DATES:"
- +3 if $Y>21
- DO R
- WRITE !," JAN 22 1957 or 22 JAN 57 or 1/22/57 or 012257"
- +4 if $Y>21
- DO R
- WRITE !," T (FOR TODAY), T+1 (FOR TOMORROW), T+2, T+7, etc."," T-1 (FOR YESTERDAY)"
- +5 if $Y>21
- DO R
- WRITE !," T-3W (3 WEEKS AGO), etc."
- +6 if $Y>21
- DO R
- WRITE !,"IF THE YEAR IS OMITTED, THE COMPUTER USES THE CURRENT YEAR"
- +7 if $Y>21
- DO R
- IF %DT'["X"
- WRITE !,"YOU MAY OMIT THE PRECISE DAY, AS: JAN, 1957",!
- +8 if $Y>21
- DO R
- IF %DT["T"
- WRITE !,"FOLLOW DATE WITH TIME, AS: JAN 22@10, T@10PM, ETC."
- +9 DO R
- +10 QUIT
- R DO MCMASS
- XECUTE DJCL
- WRITE "Press <RETURN> to Continue"
- READ DJX:10
- XECUTE DJCP
- PP DO MCMASS
- SET DJZ=+$PIECE($PIECE(^DD(DJDD,DJAT,0),"^",2),"P",2)
- if $PIECE(^DD(DJZ,.01,0),"^",2)'["P"
- QUIT
- P11 IF $DATA(@("^"_$PIECE(^DD(DJZ,.01,0),U,3)_"V(V),0)"))
- SET V(V)=$PIECE(^(0),U,1)
- +1 SET DJZ=+$PIECE($PIECE(^DD(DJZ,.01,0),"^",2),"P",2)
- if $PIECE(^DD(DJZ,.01,0),"^",2)'["P"
- QUIT
- GOTO P11
- DCS SET DJNODE=.01
- if DJ4'["P"
- QUIT
- +1 SET DJ44=$SELECT(DJ4'["'":DJ4,1:$PIECE(DJ4,"P",2))
- +2 if '$DATA(^DD(+DJ44,0,"UP"))
- QUIT
- IF $DATA(^DD(^DD(+DJ44,0,"UP"),0,"UP"))
- SET DJ44=^DD(+DJ44,0,"UP")
- SET DJNODE=$PIECE(DJJ(V),U,3)
- +3 IF DJNODE=.01
- IF $DATA(^DD(DJDD,DJ3,12.1))
- XECUTE ^(12.1)
- GOTO DCS1
- +4 KILL DIC("S")
- if '$DATA(^DD(+DJ44,DJNODE))
- QUIT
- if '$DATA(DIC(0))
- SET DIC(0)=""
- +5 IF $DATA(^DD(+DJ44,DJNODE,12.1))
- XECUTE ^(12.1)
- +6 IF '$TEST
- KILL DJNODE,DJ44
- QUIT
- DCS1 if '$DATA(DIC(0))
- SET DIC(0)=""
- if DIC(0)'=""
- KILL DIC("S")
- KILL DJNODE,DJ44
- QUIT
- MCDJHELP ;
- +1 SET MCCNT=0
- SET MCDJHELP(1)=^DD(DJDD,DJAT,3)
- +2 DO MCDJHEL1
- +3 READ !,"Press <RETURN> to Continue: ",MCXRET:DTIME
- +4 XECUTE DJCP
- +5 KILL MCDJHELP,MCCNT,MCXRET
- +6 QUIT
- MCDJHEL1 ;
- +1 SET MCCNT=MCCNT+1
- +2 if '$DATA(MCDJHELP(MCCNT))
- QUIT
- +3 FOR I=79:-1:1
- if $EXTRACT(MCDJHELP(MCCNT),I)=" "
- QUIT
- +4 IF $LENGTH(MCDJHELP(MCCNT))>79
- SET MCDJHELP(MCCNT+1)=$EXTRACT(MCDJHELP(MCCNT),I+1,$LENGTH(MCDJHELP(MCCNT)))
- SET MCDJHELP(MCCNT)=$EXTRACT(MCDJHELP(MCCNT),1,I-1)
- +5 WRITE !,MCDJHELP(MCCNT)
- +6 GOTO MCDJHEL1
- MCMASS ;Let the Screen Handlers know that the command was erase.
- +1 SET MCMASS=1
- +2 QUIT
