MCARDPL ;WISC/TJK,FDJW,JA-DISPLAY SCREEN ;8/31/92 09:03
;;2.3;Medicine;;09/13/1996
S:'$D(DJDPL) DJDPL="" I DJDPL'=DJNM S DJN=$O(^MCAR(697.3,"B",DJNM,0)) S:DJN="" DJN=-1 G ER:DJN<1
N S:'$D(DJFF) DJFF=0
K DJJ,DJF,DJKEY,DJY S:DJN'=+DJN DJN=$O(^MCAR(697.3,"B",DJN,0)) S:DJN="" DJN=-1 G ER:DJN<0 S DJ0=^MCAR(697.3,DJN,0),DJDPL=$P(DJ0,U,1),DJJ=$P(DJ0,U,2,5),DJDD=$P(DJ0,U,6),V=$O(^MCAR(697.3,DJN,1,"A",0)) S:V="" V=-1 S (DJL,DJF)=V
G ER:+V<0
D:'DJFF HDH I DJDD'=+DJDD S DIC="^MCAR(697.3,DJN,1," G N1
S DJ0="",DJ1=DJDD F V=1:1 Q:'$D(^DD(DJ1,0,"UP")) S DJ1=^("UP"),DJ2=$O(^("NM",0)) S:DJ2="" DJ2=-1 S DJ2=$O(^DD(DJ1,"B",DJ2,"")) S:DJ2="" DJ2=-1 S DJ2=$P($P(^DD(DJ1,DJ2,0),U,4),";",1) S:DJ2'=+DJ2 DJ2=""""_DJ2_"""" S DJ0="DA("_V_"),"_DJ2_","
S DIC=^DIC(DJ1,0,"GL")_DJ0,V=DJF,DIE=DIC I $D(DJST),DJST>1 S DIC=^TMP($J,"DJST",DJST,"DIC")
IF '$D(^MCAR(697.3,DJN,1,"A",V)) D
. S YMLH=$O(^MCAR(697.3,DJN,1,"A",V))
. I YMLH="" S YMLH=-1
. S (DJF,V)=YMLH
. Q
;END IF
;
N1 ;
S DJK=$O(^MCAR(697.3,DJN,1,"A",V,0)) S:DJK="" DJK=-1
G ER:DJK<0!($D(^MCAR(697.3,DJN,1,DJK,0))<0)
S DJ0=^MCAR(697.3,DJN,1,DJK,0)
S:$P(DJ0,U,5)=.01 DJKEY=V G:$P(DJ0,U,2)="" ER S @$P(DJ0,U,2) X XY I V#1=0 W DJHIN X XY W $J(V,2)," ",DJLIN
I '$P(DJ0,U,8) W:(V#1<1)&(V#1>0) DJHIN W $P(DJ0,U,1) W DJLIN W:$P(DJ0,U,5)>0 ":"
I V#1=0!(V=.5) S DJJ(V)=$P(DJ0,U,3,7)_"^"_$P(DJ0,U,12),@$P(DJ0,U,4) X XY K:$P(DJ0,U,5)<0 V(V)
I $P(DJ0,U,12)]"" D
.S DJNO=$O(^MCAR(697.3,"B",$P(DJ0,U,12),0))
.S DJJ(V)=DJJ(V)_U_$P(^MCAR(697.3,DJNO,1,0),U,4)
.K DJNO
I V#1=0!(V=.5) S $P(DJJ(V),U,8)=$P(DJ0,U,2)
G:V#1'=0 N2
;
; Is there data in the field?
IF $G(V(V))]"",DJJ(V) D ; yes, prepare it for display
. W DJHIN
. X XY
. I DJJ(V)["M" S V(V)=$E(V(V),1,+DJJ(V))
. S DJDB=""
. I DJJ(V)-$L(V(V)) S $P(DJDB," ",DJJ(V)-$L(V(V)))=" "
. S DJDB=V(V)_DJDB
. ;W V(V)
. ;I $D(DJDB) W DJDB
. ;K DJDB
. ;W DJLIN
. Q
ELSE D ; there is no data in the field, just write dots
. S $P(DJDB,".",DJJ(V))="."
. W DJLIN ;,DJDB
. ;K DJDB
. Q
;END IF
;
; Are we going to spill over to the next line?
I $L(DJDB)<80 W DJDB ; no
E W $E(DJDB,1,80-DX),!,$E(DJDB,80-DX+1,$L(DJDB)) ; yes
K DJDB
;
N2 S V=$O(^MCAR(697.3,DJN,1,"A",V)) S:V="" V=-1 S:V>DJL DJL=V G N1:V>0 S V=DJF
K DJ0,DJ1,DJ2 Q
EN S DJFF=0 G N
EN1 S DJFF=1 G N
;Q
HDH ;HEADING
S DJT=$P(DJ0,U,7) S DY=0,DX=0 X DJCP W @IOF,?(80-$L(DJT))/2-5,DJT," ",$E(DT,4,5),"/",$E(DT,6,7),"/",$E(DT,2,3)
;I $D(DJST),DJST>1 F DJK=1:1:DJST-1 W !,?DJK*2,"***",^TMP($J,"DJST",DJK,"TITLE"),"***"
;I $D(DJST),$P(DJJ,U,2)'="" W !,?3,"***",^TMP($J,"DJST",DJST,"TITLE"),"***"
Q
ER ;
Q
X DJCL W "SCREEN **",DJNM,"** HAS NOT BEEN PROPERLY CREATED. Check your 'A' XREF",*7 H 2
K DIC,DIE,DJ0,DJ1,DJDD,DJDPL,DJF,DJJ,DJK,DJKL,DJKL,DJL,DJNM,DJT,V
S DJY=-1 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCARDPL 2862 printed Dec 13, 2024@02:12:44 Page 2
MCARDPL ;WISC/TJK,FDJW,JA-DISPLAY SCREEN ;8/31/92 09:03
+1 ;;2.3;Medicine;;09/13/1996
+2 if '$DATA(DJDPL)
SET DJDPL=""
IF DJDPL'=DJNM
SET DJN=$ORDER(^MCAR(697.3,"B",DJNM,0))
if DJN=""
SET DJN=-1
if DJN<1
GOTO ER
N if '$DATA(DJFF)
SET DJFF=0
+1 KILL DJJ,DJF,DJKEY,DJY
if DJN'=+DJN
SET DJN=$ORDER(^MCAR(697.3,"B",DJN,0))
if DJN=""
SET DJN=-1
if DJN<0
GOTO ER
SET DJ0=^MCAR(697.3,DJN,0)
SET DJDPL=$PIECE(DJ0,U,1)
SET DJJ=$PIECE(DJ0,U,2,5)
SET DJDD=$PIECE(DJ0,U,6)
SET V=$ORDER(^MCAR(697.3,DJN,1,"A",0))
if V=""
SET V=-1
SET (DJL,DJF)=V
+2 if +V<0
GOTO ER
+3 if 'DJFF
DO HDH
IF DJDD'=+DJDD
SET DIC="^MCAR(697.3,DJN,1,"
GOTO N1
+4 SET DJ0=""
SET DJ1=DJDD
FOR V=1:1
if '$DATA(^DD(DJ1,0,"UP"))
QUIT
SET DJ1=^("UP")
SET DJ2=$ORDER(^("NM",0))
if DJ2=""
SET DJ2=-1
SET DJ2=$ORDER(^DD(DJ1,"B",DJ2,""))
if DJ2=""
SET DJ2=-1
SET DJ2=$PIECE($PIECE(^DD(DJ1,DJ2,0),U,4),";",1)
if DJ2'=+DJ2
SET DJ2=""""_DJ2_""""
SET DJ0="DA("_V_"),"_DJ2_","
+5 SET DIC=^DIC(DJ1,0,"GL")_DJ0
SET V=DJF
SET DIE=DIC
IF $DATA(DJST)
IF DJST>1
SET DIC=^TMP($JOB,"DJST",DJST,"DIC")
+6 IF '$DATA(^MCAR(697.3,DJN,1,"A",V))
Begin DoDot:1
+7 SET YMLH=$ORDER(^MCAR(697.3,DJN,1,"A",V))
+8 IF YMLH=""
SET YMLH=-1
+9 SET (DJF,V)=YMLH
+10 QUIT
End DoDot:1
+11 ;END IF
+12 ;
N1 ;
+1 SET DJK=$ORDER(^MCAR(697.3,DJN,1,"A",V,0))
if DJK=""
SET DJK=-1
+2 if DJK<0!($DATA(^MCAR(697.3,DJN,1,DJK,0))<0)
GOTO ER
+3 SET DJ0=^MCAR(697.3,DJN,1,DJK,0)
+4 if $PIECE(DJ0,U,5)=.01
SET DJKEY=V
if $PIECE(DJ0,U,2)=""
GOTO ER
SET @$PIECE(DJ0,U,2)
XECUTE XY
IF V#1=0
WRITE DJHIN
XECUTE XY
WRITE $JUSTIFY(V,2)," ",DJLIN
+5 IF '$PIECE(DJ0,U,8)
if (V#1<1)&(V#1>0)
WRITE DJHIN
WRITE $PIECE(DJ0,U,1)
WRITE DJLIN
if $PIECE(DJ0,U,5)>0
WRITE ":"
+6 IF V#1=0!(V=.5)
SET DJJ(V)=$PIECE(DJ0,U,3,7)_"^"_$PIECE(DJ0,U,12)
SET @$PIECE(DJ0,U,4)
XECUTE XY
if $PIECE(DJ0,U,5)<0
KILL V(V)
+7 IF $PIECE(DJ0,U,12)]""
Begin DoDot:1
+8 SET DJNO=$ORDER(^MCAR(697.3,"B",$PIECE(DJ0,U,12),0))
+9 SET DJJ(V)=DJJ(V)_U_$PIECE(^MCAR(697.3,DJNO,1,0),U,4)
+10 KILL DJNO
End DoDot:1
+11 IF V#1=0!(V=.5)
SET $PIECE(DJJ(V),U,8)=$PIECE(DJ0,U,2)
+12 if V#1'=0
GOTO N2
+13 ;
+14 ; Is there data in the field?
+15 ; yes, prepare it for display
IF $GET(V(V))]""
IF DJJ(V)
Begin DoDot:1
+16 WRITE DJHIN
+17 XECUTE XY
+18 IF DJJ(V)["M"
SET V(V)=$EXTRACT(V(V),1,+DJJ(V))
+19 SET DJDB=""
+20 IF DJJ(V)-$LENGTH(V(V))
SET $PIECE(DJDB," ",DJJ(V)-$LENGTH(V(V)))=" "
+21 SET DJDB=V(V)_DJDB
+22 ;W V(V)
+23 ;I $D(DJDB) W DJDB
+24 ;K DJDB
+25 ;W DJLIN
+26 QUIT
End DoDot:1
+27 ; there is no data in the field, just write dots
IF '$TEST
Begin DoDot:1
+28 SET $PIECE(DJDB,".",DJJ(V))="."
+29 ;,DJDB
WRITE DJLIN
+30 ;K DJDB
+31 QUIT
End DoDot:1
+32 ;END IF
+33 ;
+34 ; Are we going to spill over to the next line?
+35 ; no
IF $LENGTH(DJDB)<80
WRITE DJDB
+36 ; yes
IF '$TEST
WRITE $EXTRACT(DJDB,1,80-DX),!,$EXTRACT(DJDB,80-DX+1,$LENGTH(DJDB))
+37 KILL DJDB
+38 ;
N2 SET V=$ORDER(^MCAR(697.3,DJN,1,"A",V))
if V=""
SET V=-1
if V>DJL
SET DJL=V
if V>0
GOTO N1
SET V=DJF
+1 KILL DJ0,DJ1,DJ2
QUIT
EN SET DJFF=0
GOTO N
EN1 SET DJFF=1
GOTO N
+1 ;Q
HDH ;HEADING
+1 SET DJT=$PIECE(DJ0,U,7)
SET DY=0
SET DX=0
XECUTE DJCP
WRITE @IOF,?(80-$LENGTH(DJT))/2-5,DJT," ",$EXTRACT(DT,4,5),"/",$EXTRACT(DT,6,7),"/",$EXTRACT(DT,2,3)
+2 ;I $D(DJST),DJST>1 F DJK=1:1:DJST-1 W !,?DJK*2,"***",^TMP($J,"DJST",DJK,"TITLE"),"***"
+3 ;I $D(DJST),$P(DJJ,U,2)'="" W !,?3,"***",^TMP($J,"DJST",DJST,"TITLE"),"***"
+4 QUIT
ER ;
+1 QUIT
+2 XECUTE DJCL
WRITE "SCREEN **",DJNM,"** HAS NOT BEEN PROPERLY CREATED. Check your 'A' XREF",*7
HANG 2
+3 KILL DIC,DIE,DJ0,DJ1,DJDD,DJDPL,DJF,DJJ,DJK,DJKL,DJKL,DJL,DJNM,DJT,V
+4 SET DJY=-1
QUIT
