- MCARDML ;WISC/TJK,JA-MULTIPLE STACK DRIVER ;6/29/92 14:37
- ;;2.3;Medicine;;09/13/1996
- ; invoked by paragraph R^MCARDNJ (user input handler)
- K DJW2,DJK1 G EN3^MCARDNJ:X?1"^".N,TK^MCARDNJ:X=""!($E(X,1)="^") S:X="@" DJK1=1 S:X=" "!(X="@") X=V(V)
- S DJST=DJST+1,^TMP($J,"DJST",DJST,"DA")=V(V,"DA")
- S YMLH=$O(^MCAR(697.3,"B",$P(DJJ(V),U,6),0)) S:YMLH="" YMLH=-1
- S ^TMP($J,"DJST",DJST,"SC")=YMLH,^TMP($J,"DJST",DJST-1,"LOC")=V,^TMP($J,"DJST",DJST,"DD")=V(V,"DD"),^TMP($J,"DJST",DJST,"GN")=V(V,"GN")
- S ^TMP($J,"DJST",DJST,"FRSC")=DJN,^TMP($J,"DJST",DJST,"DIC")=^TMP($J,"DJST",DJST-1,"DIC")_^TMP($J,"DJST",DJST-1,"DA")_","_V(V,"GN")_","
- S DJZ=DJST F DJK=1:1:DJST-1 S DJZ=DJZ-1,DA(DJZ)=^TMP($J,"DJST",DJK,"DA")
- S DJNM=$P(^MCAR(697.3,^TMP($J,"DJST",DJST,"SC"),0),U,1),DIC=^TMP($J,"DJST",DJST,"DIC") S:$D(@(DIC_0_")"))=0 @(DIC_0_")")="^"_^TMP($J,"DJST",DJST,"DD")_"^^" K DJDN
- S DIC(0)="EQZM" S:'$D(DJDIS) DIC(0)=DIC(0)_"L" X DJCP D ^MCARDC G D:$D(DJK1) I X["?" X DJCL S:DJ4["S" DJT=DJDD,DJDD=+DJ4,DJY=DJAT,DJAT=.01 D ^MCARDNQ:DJ4["S"!(DJ4["D") S:DJ4["S" DJDD=DJT,DJAT=DJY
- I Y>0,$P(DJJ(V),U,7)=1 S V(V)=X D DISPLAY(V) G A
- I $Y>23 R !,"Press <RETURN> to Continue",DJZ1:DTIME K DJZ1
- I Y>0 D SAVE K V,DJMUL S DA=+Y,DJDN=+Y,^TMP($J,"DJST",DJST,"DA")=DA,@("D"_(DJST-1)_"="_DA) D ^MCARDPL S (W(V),V(V))=DJDN D ^MCARD1 S ^TMP($J,"DJST",DJST-1,"KEY")=V(DJKEY) D EN^MCARDNJ S DJW2=1
- A S DJN=^TMP($J,"DJST",DJST,"FRSC") S DJST=DJST-1 S DJNM=$P(^MCAR(697.3,DJN,0),"^",1),DIC=^TMP($J,"DJST",DJST,"DIC") S DJDN=^TMP($J,"DJST",DJST,"DA")
- K DA S DJZ=DJST I $D(DJW2),DJST>1 F DJK=1:1:DJST-1 S DJZ=DJZ-1,DA(DJZ)=^TMP($J,"DJST",DJK,"DA")
- S DA=DJDN ;DCB - Add May 4, 1994
- I $D(DJW2),DJST>1 F DJK=0:1:DJST-2 S @("D"_DJK)=^TMP($J,"DJST",DJK+1,"DA")
- I $D(DJW2) D REST S V=^TMP($J,"DJST",DJST,"LOC"),V(V)=^TMP($J,"DJST",DJST,"KEY") D ^MCARDPL K DJZ,DJW2 G N
- N S DJFF=0,V=^TMP($J,"DJST",DJST,"LOC") G TK^MCARDNJ
- SAVE S %X="V(",%Y="^TMP($J,""DJ"",DJN," D %XY^%RCR K V Q
- REST K MCDID S MCMASS=1
- K V S %X="^TMP($J,""DJ"",DJN,",%Y="V(" D %XY^%RCR Q
- D G:Y<0 D1 I Y>0 X DJCL S DY=22,DX=0 X XY W DJEOP W !,"ARE YOU SURE YOU WANT TO DELETE: NO// ",*7 R DJX:DTIME
- S DJX=$$UPPER^MCARDSE(DJX)
- I DJX["?" W "ANSWER YES OR NO -- RETURN TO CONTINUE" R DJX:DTIME G D
- G:DJX'["Y" D1 S DA=+Y,DR=".01///@" S DIE=DIC D ^DIE K DJK1 S V(V)="" G A
- D1 X DJCL W "NOTHING DELETED" G A
- DISPLAY(TEMP) ;Display the line
- N HOLD,LEN,TEXT,SPACE S SPACE="",$P(SPACE," ",80)=" "
- S TEXT=SPACE,HOLD=+DJJ(V)
- S TEXT=$E(TEXT,1,HOLD)
- S @$P(DJJ(V),U,2) X XY
- W DJHIN,TEXT,DJLIN
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCARDML 2565 printed Feb 18, 2025@23:39:04 Page 2
- MCARDML ;WISC/TJK,JA-MULTIPLE STACK DRIVER ;6/29/92 14:37
- +1 ;;2.3;Medicine;;09/13/1996
- +2 ; invoked by paragraph R^MCARDNJ (user input handler)
- +3 KILL DJW2,DJK1
- if X?1"^".N
- GOTO EN3^MCARDNJ
- if X=""!($EXTRACT(X,1)="^")
- GOTO TK^MCARDNJ
- if X="@"
- SET DJK1=1
- if X=" "!(X="@")
- SET X=V(V)
- +4 SET DJST=DJST+1
- SET ^TMP($JOB,"DJST",DJST,"DA")=V(V,"DA")
- +5 SET YMLH=$ORDER(^MCAR(697.3,"B",$PIECE(DJJ(V),U,6),0))
- if YMLH=""
- SET YMLH=-1
- +6 SET ^TMP($JOB,"DJST",DJST,"SC")=YMLH
- SET ^TMP($JOB,"DJST",DJST-1,"LOC")=V
- SET ^TMP($JOB,"DJST",DJST,"DD")=V(V,"DD")
- SET ^TMP($JOB,"DJST",DJST,"GN")=V(V,"GN")
- +7 SET ^TMP($JOB,"DJST",DJST,"FRSC")=DJN
- SET ^TMP($JOB,"DJST",DJST,"DIC")=^TMP($JOB,"DJST",DJST-1,"DIC")_^TMP($JOB,"DJST",DJST-1,"DA")_","_V(V,"GN")_","
- +8 SET DJZ=DJST
- FOR DJK=1:1:DJST-1
- SET DJZ=DJZ-1
- SET DA(DJZ)=^TMP($JOB,"DJST",DJK,"DA")
- +9 SET DJNM=$PIECE(^MCAR(697.3,^TMP($JOB,"DJST",DJST,"SC"),0),U,1)
- SET DIC=^TMP($JOB,"DJST",DJST,"DIC")
- if $DATA(@(DIC_0_")"))=0
- SET @(DIC_0_")")="^"_^TMP($JOB,"DJST",DJST,"DD")_"^^"
- KILL DJDN
- +10 SET DIC(0)="EQZM"
- if '$DATA(DJDIS)
- SET DIC(0)=DIC(0)_"L"
- XECUTE DJCP
- DO ^MCARDC
- if $DATA(DJK1)
- GOTO D
- IF X["?"
- XECUTE DJCL
- if DJ4["S"
- SET DJT=DJDD
- SET DJDD=+DJ4
- SET DJY=DJAT
- SET DJAT=.01
- if DJ4["S"!(DJ4["D")
- DO ^MCARDNQ
- if DJ4["S"
- SET DJDD=DJT
- SET DJAT=DJY
- +11 IF Y>0
- IF $PIECE(DJJ(V),U,7)=1
- SET V(V)=X
- DO DISPLAY(V)
- GOTO A
- +12 IF $Y>23
- READ !,"Press <RETURN> to Continue",DJZ1:DTIME
- KILL DJZ1
- +13 IF Y>0
- DO SAVE
- KILL V,DJMUL
- SET DA=+Y
- SET DJDN=+Y
- SET ^TMP($JOB,"DJST",DJST,"DA")=DA
- SET @("D"_(DJST-1)_"="_DA)
- DO ^MCARDPL
- SET (W(V),V(V))=DJDN
- DO ^MCARD1
- SET ^TMP($JOB,"DJST",DJST-1,"KEY")=V(DJKEY)
- DO EN^MCARDNJ
- SET DJW2=1
- A SET DJN=^TMP($JOB,"DJST",DJST,"FRSC")
- SET DJST=DJST-1
- SET DJNM=$PIECE(^MCAR(697.3,DJN,0),"^",1)
- SET DIC=^TMP($JOB,"DJST",DJST,"DIC")
- SET DJDN=^TMP($JOB,"DJST",DJST,"DA")
- +1 KILL DA
- SET DJZ=DJST
- IF $DATA(DJW2)
- IF DJST>1
- FOR DJK=1:1:DJST-1
- SET DJZ=DJZ-1
- SET DA(DJZ)=^TMP($JOB,"DJST",DJK,"DA")
- +2 ;DCB - Add May 4, 1994
- SET DA=DJDN
- +3 IF $DATA(DJW2)
- IF DJST>1
- FOR DJK=0:1:DJST-2
- SET @("D"_DJK)=^TMP($JOB,"DJST",DJK+1,"DA")
- +4 IF $DATA(DJW2)
- DO REST
- SET V=^TMP($JOB,"DJST",DJST,"LOC")
- SET V(V)=^TMP($JOB,"DJST",DJST,"KEY")
- DO ^MCARDPL
- KILL DJZ,DJW2
- GOTO N
- N SET DJFF=0
- SET V=^TMP($JOB,"DJST",DJST,"LOC")
- GOTO TK^MCARDNJ
- SAVE SET %X="V("
- SET %Y="^TMP($J,""DJ"",DJN,"
- DO %XY^%RCR
- KILL V
- QUIT
- REST KILL MCDID
- SET MCMASS=1
- +1 KILL V
- SET %X="^TMP($J,""DJ"",DJN,"
- SET %Y="V("
- DO %XY^%RCR
- QUIT
- D if Y<0
- GOTO D1
- IF Y>0
- XECUTE DJCL
- SET DY=22
- SET DX=0
- XECUTE XY
- WRITE DJEOP
- WRITE !,"ARE YOU SURE YOU WANT TO DELETE: NO// ",*7
- READ DJX:DTIME
- +1 SET DJX=$$UPPER^MCARDSE(DJX)
- +2 IF DJX["?"
- WRITE "ANSWER YES OR NO -- RETURN TO CONTINUE"
- READ DJX:DTIME
- GOTO D
- +3 if DJX'["Y"
- GOTO D1
- SET DA=+Y
- SET DR=".01///@"
- SET DIE=DIC
- DO ^DIE
- KILL DJK1
- SET V(V)=""
- GOTO A
- D1 XECUTE DJCL
- WRITE "NOTHING DELETED"
- GOTO A
- DISPLAY(TEMP) ;Display the line
- +1 NEW HOLD,LEN,TEXT,SPACE
- SET SPACE=""
- SET $PIECE(SPACE," ",80)=" "
- +2 SET TEXT=SPACE
- SET HOLD=+DJJ(V)
- +3 SET TEXT=$EXTRACT(TEXT,1,HOLD)
- +4 SET @$PIECE(DJJ(V),U,2)
- XECUTE XY
- +5 WRITE DJHIN,TEXT,DJLIN
- +6 QUIT