MCARDNJ2 ;WISC/TJK,JA-FUNCTION FOR DISPLAY ONLY ;8/22/96 15:28
;;2.3;Medicine;;09/13/1996
FUNC ;FUNCTION COMMANDS
X DJCP W DJHIN X XY W "FUNCTIONS",DJLIN
W !!," ^ -- Quit"
W:$P(^MCAR(697.3,DJN,0),"^",3)]"" ?41,"U -- Up a page"
W !," N -- New record"
W:$P(^MCAR(697.3,DJN,0),"^",5)]"" ?41,"D -- Down a page"
LST X DJCL W "FUNCTION: ",$S($P(DJJ,U,4)="":"N",1:"D"),"//" R X:DTIME S:'$T X="^" S:X=""!(X["D") X="D" G MOD:X?1"^"1N.N G Q:X["N"&(DJP=0) Q:X["N"&(DJP=1)
LS1 G:X?1"^" OUT I X["D"&($P(DJJ,U,4)]"")&($D(DJDN)) D SAVE S DJN=$P(DJJ,U,4) S DJN=$O(^MCAR(697.3,"B",DJN,0)) S:DJN="" DJN=-1 S DJFF=0 D N^MCARDPL Q:$D(DJY) S (DA,W(V))=DJDN D ^MCARD1 G EN2^MCARDNJ
I X["D"&($P(DJJ,U,4)="") S:$P(DJJ,U,2)'="" DJFF=0 G Q
G:X["U" PREV
G LST
MOD I $D(DJJ($P(X,U,2))) S V=$P(X,"^",2) S:DJ4["M"&($D(DJDIS)) DJSW1=1,DJDIS=0 S V=V-.001 G NXT
PREV G LST:$P(DJJ,U,2)="" S DJN=$P(DJJ,U,2) S:DJN'=+DJN DJN=$O(^MCAR(697.3,"B",DJN,0)) S:DJN="" DJN=-1 S DJFF=0 D REST D N^MCARDPL G NXT
Q I $P(^MCAR(697.3,DJN,0),U,3)'="" F DJK=0:0 S (DJDPL,DJNM)=$P(^MCAR(697.3,DJN,0),U,3),DJN=$O(^MCAR(697.3,"B",DJNM,0)) S:DJN="" DJN=-1 Q:$P(^MCAR(697.3,DJN,0),U,3)=""
K V,DJ0,DJAT,DJDN,DJ3,DJ4,DJQ I '$D(DJW1) D ^MCARDPL G EN2^MCARDNJ
OUT K DJSV,DJ0,DJAT,DJK,DJDN,DJ3,V,DJJ,DJQ,DIC,DJDD,DX,DY,DJSM,DJDIC,DJKEY S DJFF=0 Q
KILL K DB,DC,DE,DG,DH,DI,DK,DL,DM,DP,DR,DW Q
SAVE S %X="V(",%Y="^TMP($J,""DJ"",DJN," D %XY^%RCR K V Q
REST K V S %X="^TMP($J,""DJ"",DJN,",%Y="V(" D %XY^%RCR Q
NXT G NXT^MCARDNJ
;CALLED BY MCARDNJ
COMPUTE D COMPUTE1 G NXT
COMPUTE1 D:$D(DA(1)) SET X $P(^DD(DJDD,$P(DJJ(V),U,3),0),U,5,99) D BLANK^MCARD1 S V(V)=X D:$D(DA(1)) RESET S @$P(DJJ(V),U,2) X XY S $P(DJDB," ",DJJ(V))=" " W DJDB X XY W:X DJHIN,X K DJDB X XY
Q
SET S DJMD0=D0,DJMD1=D1,D0=DA(1),D1=DA Q
RESET S D0=DJMD0,D1=DJMD1 K DJMD0,DJMD1 Q
B S DJDB="" S:(DJJ(V)-$L(V(V))) $P(DJDB," ",DJJ(V)-$L(V(V)))=" " Q
D S $P(DJDB,".",DJJ(V))="."
Q
;
Z ; input reader - invoked by R^MCARDNJ
D DCS^MCARDNQ
;
; if this is a pointer multiple, do some cleanup of the system table
S X=$P(DJJ(V),"^",4)
IF X["P",X["M" D ; a pointer multiple
. K DIC("S") ;,DA
. S DG=12,DIC(0)="EQZML"
. S DIC("V")=DIC_D0_","_(+$P(DJ0,"^",4))_"," ; suspect that this is the critical variable
. S DJXX="?",Y=-1
. Q
;END IF
;
; get the input
S X="",DJSM=0,DJLG=+DJJ(V)+1
;I DJLG<81 D
;. R X#DJLG:DTIME S DJZ=$T
;E ; next line used to be concatenated with this one
S X=$$RESPONSE^MCARDSE("",DJLG-1,DX,DY),DJZ=$P(X,"~",2),X=$P(X,"~",1)
S:'DJZ X="^" S:X="" DJSM=1 K:X="" DIC("S")
I $L(X)>(DJLG-1) W @IOBS," ",*7 X XY S:'$D(V(V)) V(V)="" D B:V(V)'="",D:V(V)="",M K DJDB X XY G Z
I X?1"^".E!(X?1"?".E) S:'$D(V(V)) V(V)="" D B:V(V)'="",D:V(V)="" X XY W DJHIN X XY D M W DJLIN K DJDB X XY Q
Q
N R !,"Press <RETURN> to Continue",DJX:DTIME S DJSV=V D N^MCARDPL S V=DJSV Q
HELP W !!,*7,"Answer 'YES' or 'NO'. As a general rule, you should repaint the screen if the screen has been 'pushed up' by the word processing field"
G N
M ;W V(V) W:$D(DJDB) DJDB ; ;8/31/92 14:18
S DJDB=V(V)_$G(DJDB)
I $L(DJDB)<80 W DJDB
E W $E(DJDB,1,80-DX),!,$E(DJDB,80-DX+1,$L(DJDB))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCARDNJ2 3196 printed Dec 13, 2024@02:12:39 Page 2
MCARDNJ2 ;WISC/TJK,JA-FUNCTION FOR DISPLAY ONLY ;8/22/96 15:28
+1 ;;2.3;Medicine;;09/13/1996
FUNC ;FUNCTION COMMANDS
+1 XECUTE DJCP
WRITE DJHIN
XECUTE XY
WRITE "FUNCTIONS",DJLIN
+2 WRITE !!," ^ -- Quit"
+3 if $PIECE(^MCAR(697.3,DJN,0),"^",3)]""
WRITE ?41,"U -- Up a page"
+4 WRITE !," N -- New record"
+5 if $PIECE(^MCAR(697.3,DJN,0),"^",5)]""
WRITE ?41,"D -- Down a page"
LST XECUTE DJCL
WRITE "FUNCTION: ",$SELECT($PIECE(DJJ,U,4)="":"N",1:"D"),"//"
READ X:DTIME
if '$TEST
SET X="^"
if X=""!(X["D")
SET X="D"
if X?1"^"1N.N
GOTO MOD
if X["N"&(DJP=0)
GOTO Q
if X["N"&(DJP=1)
QUIT
LS1 if X?1"^"
GOTO OUT
IF X["D"&($PIECE(DJJ,U,4)]"")&($DATA(DJDN))
DO SAVE
SET DJN=$PIECE(DJJ,U,4)
SET DJN=$ORDER(^MCAR(697.3,"B",DJN,0))
if DJN=""
SET DJN=-1
SET DJFF=0
DO N^MCARDPL
if $DATA(DJY)
QUIT
SET (DA,W(V))=DJDN
DO ^MCARD1
GOTO EN2^MCARDNJ
+1 IF X["D"&($PIECE(DJJ,U,4)="")
if $PIECE(DJJ,U,2)'=""
SET DJFF=0
GOTO Q
+2 if X["U"
GOTO PREV
+3 GOTO LST
MOD IF $DATA(DJJ($PIECE(X,U,2)))
SET V=$PIECE(X,"^",2)
if DJ4["M"&($DATA(DJDIS))
SET DJSW1=1
SET DJDIS=0
SET V=V-.001
GOTO NXT
PREV if $PIECE(DJJ,U,2)=""
GOTO LST
SET DJN=$PIECE(DJJ,U,2)
if DJN'=+DJN
SET DJN=$ORDER(^MCAR(697.3,"B",DJN,0))
if DJN=""
SET DJN=-1
SET DJFF=0
DO REST
DO N^MCARDPL
GOTO NXT
Q IF $PIECE(^MCAR(697.3,DJN,0),U,3)'=""
FOR DJK=0:0
SET (DJDPL,DJNM)=$PIECE(^MCAR(697.3,DJN,0),U,3)
SET DJN=$ORDER(^MCAR(697.3,"B",DJNM,0))
if DJN=""
SET DJN=-1
if $PIECE(^MCAR(697.3,DJN,0),U,3)=""
QUIT
+1 KILL V,DJ0,DJAT,DJDN,DJ3,DJ4,DJQ
IF '$DATA(DJW1)
DO ^MCARDPL
GOTO EN2^MCARDNJ
OUT KILL DJSV,DJ0,DJAT,DJK,DJDN,DJ3,V,DJJ,DJQ,DIC,DJDD,DX,DY,DJSM,DJDIC,DJKEY
SET DJFF=0
QUIT
KILL KILL DB,DC,DE,DG,DH,DI,DK,DL,DM,DP,DR,DW
QUIT
SAVE SET %X="V("
SET %Y="^TMP($J,""DJ"",DJN,"
DO %XY^%RCR
KILL V
QUIT
REST KILL V
SET %X="^TMP($J,""DJ"",DJN,"
SET %Y="V("
DO %XY^%RCR
QUIT
NXT GOTO NXT^MCARDNJ
+1 ;CALLED BY MCARDNJ
COMPUTE DO COMPUTE1
GOTO NXT
COMPUTE1 if $DATA(DA(1))
DO SET
XECUTE $PIECE(^DD(DJDD,$PIECE(DJJ(V),U,3),0),U,5,99)
DO BLANK^MCARD1
SET V(V)=X
if $DATA(DA(1))
DO RESET
SET @$PIECE(DJJ(V),U,2)
XECUTE XY
SET $PIECE(DJDB," ",DJJ(V))=" "
WRITE DJDB
XECUTE XY
if X
WRITE DJHIN,X
KILL DJDB
XECUTE XY
+1 QUIT
SET SET DJMD0=D0
SET DJMD1=D1
SET D0=DA(1)
SET D1=DA
QUIT
RESET SET D0=DJMD0
SET D1=DJMD1
KILL DJMD0,DJMD1
QUIT
B SET DJDB=""
if (DJJ(V)-$LENGTH(V(V)))
SET $PIECE(DJDB," ",DJJ(V)-$LENGTH(V(V)))=" "
QUIT
D SET $PIECE(DJDB,".",DJJ(V))="."
+1 QUIT
+2 ;
Z ; input reader - invoked by R^MCARDNJ
+1 DO DCS^MCARDNQ
+2 ;
+3 ; if this is a pointer multiple, do some cleanup of the system table
+4 SET X=$PIECE(DJJ(V),"^",4)
+5 ; a pointer multiple
IF X["P"
IF X["M"
Begin DoDot:1
+6 ;,DA
KILL DIC("S")
+7 SET DG=12
SET DIC(0)="EQZML"
+8 ; suspect that this is the critical variable
SET DIC("V")=DIC_D0_","_(+$PIECE(DJ0,"^",4))_","
+9 SET DJXX="?"
SET Y=-1
+10 QUIT
End DoDot:1
+11 ;END IF
+12 ;
+13 ; get the input
+14 SET X=""
SET DJSM=0
SET DJLG=+DJJ(V)+1
+15 ;I DJLG<81 D
+16 ;. R X#DJLG:DTIME S DJZ=$T
+17 ;E ; next line used to be concatenated with this one
+18 SET X=$$RESPONSE^MCARDSE("",DJLG-1,DX,DY)
SET DJZ=$PIECE(X,"~",2)
SET X=$PIECE(X,"~",1)
+19 if 'DJZ
SET X="^"
if X=""
SET DJSM=1
if X=""
KILL DIC("S")
+20 IF $LENGTH(X)>(DJLG-1)
WRITE @IOBS," ",*7
XECUTE XY
if '$DATA(V(V))
SET V(V)=""
if V(V)'=""
DO B
if V(V)=""
DO D
DO M
KILL DJDB
XECUTE XY
GOTO Z
+21 IF X?1"^".E!(X?1"?".E)
if '$DATA(V(V))
SET V(V)=""
if V(V)'=""
DO B
if V(V)=""
DO D
XECUTE XY
WRITE DJHIN
XECUTE XY
DO M
WRITE DJLIN
KILL DJDB
XECUTE XY
QUIT
+22 QUIT
N READ !,"Press <RETURN> to Continue",DJX:DTIME
SET DJSV=V
DO N^MCARDPL
SET V=DJSV
QUIT
HELP WRITE !!,*7,"Answer 'YES' or 'NO'. As a general rule, you should repaint the screen if the screen has been 'pushed up' by the word processing field"
+1 GOTO N
M ;W V(V) W:$D(DJDB) DJDB ; ;8/31/92 14:18
+1 SET DJDB=V(V)_$GET(DJDB)
+2 IF $LENGTH(DJDB)<80
WRITE DJDB
+3 IF '$TEST
WRITE $EXTRACT(DJDB,1,80-DX),!,$EXTRACT(DJDB,80-DX+1,$LENGTH(DJDB))
+4 QUIT
