- 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 Feb 18, 2025@23:39:12 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