MCARDNJ ;WISC/TJK,JA-INPUT TO SCREEN ;8/31/92 15:28
;;2.3;Medicine;;09/13/1996
K DJDN
I '$D(DJDN)&($P(DJJ,U,2)'="") G EN2^MCARDNJ1
;
S:'$D(DJDPL) DJDPL=""
EN ;
I $D(DJDN)=0 S:$D(DJKEY) DJNX=DJKEY
S DJQ=0,DJP=0,DJMU=0 I DJDPL'=DJNM D ^MCARDPL G TK
EN2 ;
S MCMASS=1 K MCDID
D:$D(MCHELPSW) FUNC^MCARDNQ2
S V=DJF-.01
NXT ;
I $D(V(V)),DJST>1,($G(DJAT)=.01) S ^TMP($J,"DJST",DJST-1,"KEY")=V(V)
S V=$O(DJJ($S($D(DJNX):DJNX-.001,1:V))) S:V="" V=-1
G LST:V<0,TK:$P(DJJ(V),U,5)&($P(DJJ(V),U,3)=.01)&('$D(DJDN)),COMPUTE^MCARDNJ2:$P(DJJ(V),U,4)["C" I $P(DJJ(V),U,5),$P(DJJ(V),U,4)'["W" G NXT
I $D(DJFLAG) S V=DJFLAG K DJFLAG
;
TK K DJNX S DJMU=0,@$P(DJJ(V),U,2),DJAT=$P(DJJ(V),U,3),DJ0=^DD(DJDD,DJAT,0),DJ4=$P(DJJ(V),U,4),DJ3=$P(DJJ(V),U,3) D START^MCARDHLP
S:DJ4["M" DJMU=1 ; if a multiple, set the multiple flag
G LH:DJAT<0,NXT:DJAT=.001 X XY G EN2:'DJJ(V)
I DJ4["W" S MCMASS=1 K MCDID I '($D(DJDIS)!($P(DJJ(V),U,5))) X DJCP S DA=DJDN,DR=DJ3,DIE=DIC D ^DIE D N^MCARDNJ2 D:$D(Y) EN3^MCARDNJ1 G NXT
I DJ4["W" S MCMASS=1 K MCDID I $D(DJDIS)!($P(DJJ(V),U,5)=1) D WP^MCARDNJ1 G NXT
G:$D(DJDIS)&($D(DJDN)) LST
S YMLH=$O(^MCAR(697.3,DJN,1,"A",V,0)) S:YMLH="" YMLH=-1
I $G(^MCAR(697.3,DJN,1,YMLH,2))'="" X ^(2) S @$P(DJJ(V),U,2) X XY G:$D(DJNX) NXT
I DJAT'=.01,$D(^MCAR(697.3,DJN,1,YMLH,3)),V(V)="" S V(V)=^(3),DIE=DIC,DA=DJDN,DR=DJAT_"///"_V(V) D ^DIE D EN3^MCARDNJ1
R ; get input from user
D:'$D(DJNX) HL,Z^MCARDNJ2 ; invoke the user input routine
I X="",DJ4["R",DJAT'=.01,V(V)="" G Q1
S DJXX=$E(X,1) G TK:X="^D"&($P(DJJ,U,4)=""),TK:X="^U"&($P(DJJ,U,2)=""),LS1:(X="^D"!(X="^U"))&($D(DJDN)),LS:X="^N"&($D(DJDN))
I $E(X,1)=U G FUNC^MCARDBL
RETURN G T4:(DJSM!(DJXX="<")!(DJXX=">")!(X?1"^"))&($D(DJDN)),OUT:X=U&(DJAT=.01)&('$D(DJDN)),TK:X?1"^".A
S:$D(DJSW1) DJDIS=1 K DJSW1
I DJMU GOTO ^MCARDML ; if a multiple, invoke the multiple processor
;
EN3 G T4:DJSM,OUT:X=""&(DJAT=.01)&('$D(DJDN)),OUT:X="^"&(DJAT=.01)&('$D(DJDN)),T1^MCARDNJ1:X="" X XY S $P(DJDB," ",DJJ(V))=" " D W(DJDB) K DJDB
S DJXX=$E(X,1) G U:X?1"^"&(DJAT=.01),T4:DJXX="^"!(DJXX="<")!(DJXX=">"),K1^MCARDNJ1:X?1"?".E&(DJAT[".01")&('$D(DJDN)),Q1:X?1"?".E
I X["^" W *7 G TK
I X="@" D:DJAT>0 ^MCARDNK S:DJST>1&(DJAT=.01) ^TMP($J,"DJST",DJST-1,"KEY")="" G TK:X'="@",T3
G ^MCARDNJ1
T3 S V(V)=$S(X="@":"",1:X)
G:DJAT=.01&(V(V)="") Q G T4
Q1 D ^MCARDNQ S @$P(DJJ(V),U,2) X XY G R
HL G H1:'$D(V(V)),H1:V(V)="",H2
H1 X XY W DJHIN X XY S $P(DJDB,".",DJJ(V))="."
I $L(DJDB)<80 W DJDB
E W $E(DJDB,1,80-DX),!,$E(DJDB,80-DX+1,$L(DJDB))
W DJLIN K DJDB X XY
Q
H2 S DJDB="" S:(DJJ(V)-$L(V(V))) $P(DJDB," ",DJJ(V)-$L(V(V)))=" " X XY D W(DJDB) X XY W DJHIN X XY S V(V)=$S($D(Y(0,0)):$E(Y(0,0),1,+DJJ(V)),1:V(V))
I $L(V(V))<80 W V(V)
E W $E(V(V),1,80-DX),!,$E(V(V),80-DX+1,$L(V(V)))
K Y(0,0) X XY K DJDB
Q
LH I DJ4["R" X DJCL W DJHIN X XY W "DATA REQUIRED",DJLIN,*7 S @$P(DJJ(V),U,2) X XY G TK
T4 ;
G:'($D(DJDN)) TK S @$P(DJJ(V),U,2) X XY
I '$D(V(V)) D G T5
.S $P(DJDB,".",DJJ(V))="."
.W DJLIN D W(DJDB) K DJDB
I V(V)="" D G T5
.S $P(DJDB,".",DJJ(V))="."
.W DJLIN D W(DJDB) K DJDB
U I V(V)'="" S @$P(DJJ(V),U,2) X XY W DJHIN X XY S DJDB="" S:(DJJ(V)-$L(V(V))) $P(DJDB," ",DJJ(V)-$L(V(V)))=" " D W(V(V)_$G(DJDB)) K DJDB
T5 Q:X?1"^"&($P(DJJ,U,2)="")&('$D(DJDN)) G LS1:X?1"^",NX:X'?1"^".N
S DJY=$P(X,U,2) I X?1"^".N,$D(DJJ(DJY)),'$P(DJJ(DJY),U,5),$P(DJJ(DJY),U,4)'["C" S V=DJY-.01 K DIC("S") G NXT
E X DJCL W *7,"Number is out of range or field is read only or computed." S V=V-.01 G NXT
NX G NXT:X=">" I X="<" S DJ0=V G EN2:V<2 F V=-1:0 S V=$O(DJJ(V)) S:V="" V=-1 I (V'=-1),($O(DJJ(V)))=DJ0 G:($P(DJJ(V),U,4)["C")!($P(DJJ(V),U,5)=1)!($P(DJJ(V),U,4)["W") NX S V=V-.001 G NXT
G Q1:X["^",NXT
P G TK:$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 EN2
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
OUT K DJSV,DJ0,DJAT,DJK,DJDN,DJ3,V,DJJ,DJQ,DIC,DJDD,DX,DY,DJSM,DJDIC,DJKEY,DO,MCMASS S DJFF=0 Q
LST G ^MCARDNJ2:$D(DJDIS) S X="D"
LS X DJCL 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
I X["D"&($P(DJJ,U,4)="") S:$P(DJJ,U,2)'="" DJFF=0 G Q
G:X["U" P
G TK
E W *7 G LS
KILL K DB 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
W(X) ;WRITE OUT A FIELD
I $L(X)<80 W X
E W $E(X,1,80-DX),!,$E(X,80-DX+1,$L(X))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCARDNJ 4794 printed Oct 16, 2024@18:13:15 Page 2
MCARDNJ ;WISC/TJK,JA-INPUT TO SCREEN ;8/31/92 15:28
+1 ;;2.3;Medicine;;09/13/1996
+2 KILL DJDN
+3 IF '$DATA(DJDN)&($PIECE(DJJ,U,2)'="")
GOTO EN2^MCARDNJ1
+4 ;
+5 if '$DATA(DJDPL)
SET DJDPL=""
EN ;
+1 IF $DATA(DJDN)=0
if $DATA(DJKEY)
SET DJNX=DJKEY
+2 SET DJQ=0
SET DJP=0
SET DJMU=0
IF DJDPL'=DJNM
DO ^MCARDPL
GOTO TK
EN2 ;
+1 SET MCMASS=1
KILL MCDID
+2 if $DATA(MCHELPSW)
DO FUNC^MCARDNQ2
+3 SET V=DJF-.01
NXT ;
+1 IF $DATA(V(V))
IF DJST>1
IF ($GET(DJAT)=.01)
SET ^TMP($JOB,"DJST",DJST-1,"KEY")=V(V)
+2 SET V=$ORDER(DJJ($SELECT($DATA(DJNX):DJNX-.001,1:V)))
if V=""
SET V=-1
+3 if V<0
GOTO LST
if $PIECE(DJJ(V),U,5)&($PIECE(DJJ(V),U,3)=.01)&('$DATA(DJDN))
GOTO TK
if $PIECE(DJJ(V),U,4)["C"
GOTO COMPUTE^MCARDNJ2
IF $PIECE(DJJ(V),U,5)
IF $PIECE(DJJ(V),U,4)'["W"
GOTO NXT
+4 IF $DATA(DJFLAG)
SET V=DJFLAG
KILL DJFLAG
+5 ;
TK KILL DJNX
SET DJMU=0
SET @$PIECE(DJJ(V),U,2)
SET DJAT=$PIECE(DJJ(V),U,3)
SET DJ0=^DD(DJDD,DJAT,0)
SET DJ4=$PIECE(DJJ(V),U,4)
SET DJ3=$PIECE(DJJ(V),U,3)
DO START^MCARDHLP
+1 ; if a multiple, set the multiple flag
if DJ4["M"
SET DJMU=1
+2 if DJAT<0
GOTO LH
if DJAT=.001
GOTO NXT
XECUTE XY
if 'DJJ(V)
GOTO EN2
+3 IF DJ4["W"
SET MCMASS=1
KILL MCDID
IF '($DATA(DJDIS)!($PIECE(DJJ(V),U,5)))
XECUTE DJCP
SET DA=DJDN
SET DR=DJ3
SET DIE=DIC
DO ^DIE
DO N^MCARDNJ2
if $DATA(Y)
DO EN3^MCARDNJ1
GOTO NXT
+4 IF DJ4["W"
SET MCMASS=1
KILL MCDID
IF $DATA(DJDIS)!($PIECE(DJJ(V),U,5)=1)
DO WP^MCARDNJ1
GOTO NXT
+5 if $DATA(DJDIS)&($DATA(DJDN))
GOTO LST
+6 SET YMLH=$ORDER(^MCAR(697.3,DJN,1,"A",V,0))
if YMLH=""
SET YMLH=-1
+7 IF $GET(^MCAR(697.3,DJN,1,YMLH,2))'=""
XECUTE ^(2)
SET @$PIECE(DJJ(V),U,2)
XECUTE XY
if $DATA(DJNX)
GOTO NXT
+8 IF DJAT'=.01
IF $DATA(^MCAR(697.3,DJN,1,YMLH,3))
IF V(V)=""
SET V(V)=^(3)
SET DIE=DIC
SET DA=DJDN
SET DR=DJAT_"///"_V(V)
DO ^DIE
DO EN3^MCARDNJ1
R ; get input from user
+1 ; invoke the user input routine
if '$DATA(DJNX)
DO HL
DO Z^MCARDNJ2
+2 IF X=""
IF DJ4["R"
IF DJAT'=.01
IF V(V)=""
GOTO Q1
+3 SET DJXX=$EXTRACT(X,1)
if X="^D"&($PIECE(DJJ,U,4)="")
GOTO TK
if X="^U"&($PIECE(DJJ,U,2)="")
GOTO TK
if (X="^D"!(X="^U"))&($DATA(DJDN))
GOTO LS1
if X="^N"&($DATA(DJDN))
GOTO LS
+4 IF $EXTRACT(X,1)=U
GOTO FUNC^MCARDBL
RETURN if (DJSM!(DJXX="<")!(DJXX=">")!(X?1"^"))&($DATA(DJDN))
GOTO T4
if X=U&(DJAT=.01)&('$DATA(DJDN))
GOTO OUT
if X?1"^".A
GOTO TK
+1 if $DATA(DJSW1)
SET DJDIS=1
KILL DJSW1
+2 ; if a multiple, invoke the multiple processor
IF DJMU
GOTO ^MCARDML
+3 ;
EN3 if DJSM
GOTO T4
if X=""&(DJAT=.01)&('$DATA(DJDN))
GOTO OUT
if X="^"&(DJAT=.01)&('$DATA(DJDN))
GOTO OUT
if X=""
GOTO T1^MCARDNJ1
XECUTE XY
SET $PIECE(DJDB," ",DJJ(V))=" "
DO W(DJDB)
KILL DJDB
+1 SET DJXX=$EXTRACT(X,1)
if X?1"^"&(DJAT=.01)
GOTO U
if DJXX="^"!(DJXX="<")!(DJXX=">")
GOTO T4
if X?1"?".E&(DJAT[".01")&('$DATA(DJDN))
GOTO K1^MCARDNJ1
if X?1"?".E
GOTO Q1
+2 IF X["^"
WRITE *7
GOTO TK
+3 IF X="@"
if DJAT>0
DO ^MCARDNK
if DJST>1&(DJAT=.01)
SET ^TMP($JOB,"DJST",DJST-1,"KEY")=""
if X'="@"
GOTO TK
GOTO T3
+4 GOTO ^MCARDNJ1
T3 SET V(V)=$SELECT(X="@":"",1:X)
+1 if DJAT=.01&(V(V)="")
GOTO Q
GOTO T4
Q1 DO ^MCARDNQ
SET @$PIECE(DJJ(V),U,2)
XECUTE XY
GOTO R
HL if '$DATA(V(V))
GOTO H1
if V(V)=""
GOTO H1
GOTO H2
H1 XECUTE XY
WRITE DJHIN
XECUTE XY
SET $PIECE(DJDB,".",DJJ(V))="."
+1 IF $LENGTH(DJDB)<80
WRITE DJDB
+2 IF '$TEST
WRITE $EXTRACT(DJDB,1,80-DX),!,$EXTRACT(DJDB,80-DX+1,$LENGTH(DJDB))
+3 WRITE DJLIN
KILL DJDB
XECUTE XY
+4 QUIT
H2 SET DJDB=""
if (DJJ(V)-$LENGTH(V(V)))
SET $PIECE(DJDB," ",DJJ(V)-$LENGTH(V(V)))=" "
XECUTE XY
DO W(DJDB)
XECUTE XY
WRITE DJHIN
XECUTE XY
SET V(V)=$SELECT($DATA(Y(0,0)):$EXTRACT(Y(0,0),1,+DJJ(V)),1:V(V))
+1 IF $LENGTH(V(V))<80
WRITE V(V)
+2 IF '$TEST
WRITE $EXTRACT(V(V),1,80-DX),!,$EXTRACT(V(V),80-DX+1,$LENGTH(V(V)))
+3 KILL Y(0,0)
XECUTE XY
KILL DJDB
+4 QUIT
LH IF DJ4["R"
XECUTE DJCL
WRITE DJHIN
XECUTE XY
WRITE "DATA REQUIRED",DJLIN,*7
SET @$PIECE(DJJ(V),U,2)
XECUTE XY
GOTO TK
T4 ;
+1 if '($DATA(DJDN))
GOTO TK
SET @$PIECE(DJJ(V),U,2)
XECUTE XY
+2 IF '$DATA(V(V))
Begin DoDot:1
+3 SET $PIECE(DJDB,".",DJJ(V))="."
+4 WRITE DJLIN
DO W(DJDB)
KILL DJDB
End DoDot:1
GOTO T5
+5 IF V(V)=""
Begin DoDot:1
+6 SET $PIECE(DJDB,".",DJJ(V))="."
+7 WRITE DJLIN
DO W(DJDB)
KILL DJDB
End DoDot:1
GOTO T5
U IF V(V)'=""
SET @$PIECE(DJJ(V),U,2)
XECUTE XY
WRITE DJHIN
XECUTE XY
SET DJDB=""
if (DJJ(V)-$LENGTH(V(V)))
SET $PIECE(DJDB," ",DJJ(V)-$LENGTH(V(V)))=" "
DO W(V(V)_$GET(DJDB))
KILL DJDB
T5 if X?1"^"&($PIECE(DJJ,U,2)="")&('$DATA(DJDN))
QUIT
if X?1"^"
GOTO LS1
if X'?1"^".N
GOTO NX
+1 SET DJY=$PIECE(X,U,2)
IF X?1"^".N
IF $DATA(DJJ(DJY))
IF '$PIECE(DJJ(DJY),U,5)
IF $PIECE(DJJ(DJY),U,4)'["C"
SET V=DJY-.01
KILL DIC("S")
GOTO NXT
+2 IF '$TEST
XECUTE DJCL
WRITE *7,"Number is out of range or field is read only or computed."
SET V=V-.01
GOTO NXT
NX if X=">"
GOTO NXT
IF X="<"
SET DJ0=V
if V<2
GOTO EN2
FOR V=-1:0
SET V=$ORDER(DJJ(V))
if V=""
SET V=-1
IF (V'=-1)
IF ($ORDER(DJJ(V)))=DJ0
if ($PIECE(DJJ(V),U,4)["C")!($PIECE(DJJ(V),U,5)=1)!($PIECE(DJJ(V),U,4)["W")
GOTO NX
SET V=V-.001
GOTO NXT
+1 if X["^"
GOTO Q1
GOTO NXT
P if $PIECE(DJJ,U,2)=""
GOTO TK
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 EN2
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
OUT KILL DJSV,DJ0,DJAT,DJK,DJDN,DJ3,V,DJJ,DJQ,DIC,DJDD,DX,DY,DJSM,DJDIC,DJKEY,DO,MCMASS
SET DJFF=0
QUIT
LST if $DATA(DJDIS)
GOTO ^MCARDNJ2
SET X="D"
LS XECUTE DJCL
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
+1 IF X["D"&($PIECE(DJJ,U,4)="")
if $PIECE(DJJ,U,2)'=""
SET DJFF=0
GOTO Q
+2 if X["U"
GOTO P
+3 GOTO TK
+4 IF '$TEST
WRITE *7
GOTO LS
KILL KILL DB
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
W(X) ;WRITE OUT A FIELD
+1 IF $LENGTH(X)<80
WRITE X
+2 IF '$TEST
WRITE $EXTRACT(X,1,80-DX),!,$EXTRACT(X,80-DX+1,$LENGTH(X))
+3 QUIT
