Ignore:
Timestamp:
Dec 4, 2009, 12:11:15 AM (14 years ago)
Author:
George Lilly
Message:

revised back to 6/30/08 version

File:
1 edited

Legend:

Unmodified
Added
Removed

  • WorldVistAEHR/trunk/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XDRDSHOW.m

    r613 r623  
    1 XDRDSHOW        ;SF-IRMFO.SEA/JLI - DISPLAY DATA IN FIELDS, GET OVERWRITES ;01/30/2008
    2         ;;7.3;TOOLKIT;**23,49,78,112**;Apr 25, 1995;Build 1
    3         ;;
    4 SHOW(FILE,REC1,REC2,FLDS,REVIEW)        ;
    5         N FILDIC,MULT,DDVAL,NAMIEN1,NAMIEN2,NAMREC1,NAMREC2,FIRSTIME,MPIMB
    6         S FILDIC=$G(^DIC(FILE,0,"GL")) Q:FILDIC=""
    7         S REVIEW=+$G(REVIEW)
    8         S FILREC1=FILDIC_"REC1)"
    9         S FILREC2=FILDIC_"REC2)"
    10         S NAMREC1=$P($G(@FILREC1@(0)),U) I NAMREC1="" Q
    11         S NAMREC2=$P($G(@FILREC2@(0)),U) I NAMREC2="" Q
    12         I FILE=63 D
    13         . S NAMIEN1=+$P(@FILREC1@(0),U,3),NAMIEN2=+$P(@FILREC2@(0),U,3)
    14         . S NAMREC1=$P(^DPT(NAMIEN1,0),U),NAMREC2=$P(^DPT(NAMIEN2,0),U)
    15         I $P(^DD(FILE,.01,0),U,2)["P" D
    16         . N XFIL
    17         . S XFIL=+$P($P($G(^DD(FILE,.01,0)),U,2),"P",2) Q:XFIL'>0
    18         . S XFIL=$G(^DIC(XFIL,0,"GL")) Q:XFIL=""
    19         . S NAMREC1=$P(@(XFIL_NAMREC1_",0)"),U)
    20         . S NAMREC2=$P(@(XFIL_NAMREC2_",0)"),U)
    21         ;
    22         ;   recalc CMOR scores
    23         I FILE=2,$D(^DD(FILE,991.06)) D
    24         . N RGDFN S RGDFN=REC1 D CALC^RGVCCMR2
    25         . N RGDFN S RGDFN=REC2 D CALC^RGVCCMR2
    26         . Q
    27         ;
    28         ;   check for multiple birth indicator in MPI
    29         S FIRSTIME=1
    30         I FILE=2 D
    31         . I $G(^DPT(REC1,"MPIMB"))="Y"!($G(^DPT(REC2,"MPIMB"))="Y") S MPIMB=1
    32         . E  S MPIMB=0
    33         ;
    34         D HEADER
    35 LOOP    ;
    36         S FLD=0
    37         F FLD=0:0 S FLD=$O(^DD(FILE,FLD)) Q:FLD'>0  D  I NLIN<6 D PAGE Q:$D(DIRUT)  D HEADER
    38         . I FILE=63,$P($G(^DD(FILE,FLD,0)),U)="NAME" Q  ;scrn patient file data. From Lab
    39         . I FILE'=2,$P($G(^DD(FILE,FLD,0)),U,2)["P2" Q  ;From DINUM pointers.
    40         . S DDVAL=$G(^DD(FILE,FLD,0))
    41         . S NODE=$P($P(DDVAL,U,4),";")
    42         . S PIECE=$P($P(DDVAL,U,4),";",2)
    43         . I PIECE=0 S MULT(FLD)=""
    44         . I PIECE>0 D
    45         . . S X1=$P($G(@FILREC1@(NODE)),U,PIECE),X1=$$TYPE(X1,$P(DDVAL,U,2),DDVAL,REC1)
    46         . . S X2=$P($G(@FILREC2@(NODE)),U,PIECE),X2=$$TYPE(X2,$P(DDVAL,U,2),DDVAL,REC2)
    47         . . I X1'=""!(X2'="") D
    48         . . . S X0="    "
    49         . . . S XN=$P(DDVAL,U)
    50         . . . S XDRA=0
    51         . . . I X1'=""&(X2'=""),X1'=X2 D
    52         . . . . I FILE=2,((FLD=991.01)!(FLD=991.02)) Q  ;jds restrict ICN overwrites for MPI
    53         . . . . S X0=$S($D(FLDS(FLD)):"||||",1:"****"),NDIFFS=NDIFFS+1,DIFFS(NDIFFS)=FLD,XDRA=1 I REVIEW S NLIN=NLIN-1
    54         . . . I 'REVIEW!XDRA D
    55         . . . . W ! S NLIN=NLIN-1
    56         . . . . F  Q:XN=""&(X1="")&(X2="")  D
    57         . . . . . W !,X0,"  ",$E(XN,1,20),?30,$E(X1,1,20),?55,$E(X2,1,20)
    58         . . . . . S NLIN=NLIN-1
    59         . . . . . S X0="    ",XN=$E(XN,21,$L(XN))
    60         . . . . . S X1=$E(X1,21,$L(X1))
    61         . . . . . S X2=$E(X2,21,$L(X2))
    62 MULT    I '$D(DIRUT) D
    63         . I $G(NDIFFS)>0 D PAGE Q:$D(DIRUT)  D HEADER
    64         . I $D(MULT) D
    65         . . F FLD=0:0 S FLD=$O(MULT(FLD)) Q:FLD'>0  D  I NLIN<6 D PAGE Q:$D(DIRUT)  D HEADER
    66         . . . S DDVAL=^DD(FILE,FLD,0)
    67         . . . S NAME=$P(DDVAL,U)
    68         . . . S NODE=$P($P(DDVAL,U,4),";")
    69         . . . S NOD1=$NA(@FILREC1@(NODE))
    70         . . . S NOD2=$NA(@FILREC2@(NODE))
    71         . . . S N1=0,N2=0
    72         . . . F I=0:0 S I=$O(@NOD1@(I)) Q:I'>0  S N1=N1+1
    73         . . . F I=0:0 S I=$O(@NOD2@(I)) Q:I'>0  S N2=N2+1
    74         . . . I N1'=0!(N2'=0) D
    75         . . . . S N1=$S(N1>1:N1_" entries",N1>0:N1_" entry",1:"---")
    76         . . . . S N2=$S(N2>1:N2_" entries",N2>0:N2_" entry",1:"---")
    77         . . . . W !!,$E(NAME,1,25),?30,N1,?55,N2
    78         . . . . S NLIN=NLIN-2
    79         Q
    80 PAGE    ;
    81         I IOST'["C-"!$D(ZTQUEUED) Q
    82         W !
    83         I '$D(DIFFS)!'REVIEW S DIR(0)="E" D ^DIR K DIR
    84         I $D(DIFFS)&REVIEW D
    85         . S DIR(0)="LO^1:"_NDIFFS,DIR("A")="OVERWRITE data for selected fields"
    86         . F I=1:1:NDIFFS W !,I,"  ",$P(^DD(FILE,DIFFS(I),0),U)
    87         . W ! D ^DIR K DIR
    88         . I X="",$D(DIRUT) K DIRUT
    89         . S I="" F  S I=$O(Y(I)) Q:I=""  S Y=Y(I) K Y(I) D
    90         . . F  Q:Y=","  Q:Y=""  S X=$D(FLDS(DIFFS(+Y))) K:X=1 FLDS(DIFFS(+Y)) S:X=0 FLDS(DIFFS(+Y))="" S Y=$P(Y,",",2,999)
    91         Q
    92         ;
    93 HEADER  ;
    94         N REC1MB,REC2MB
    95         I '$G(FIRSTIME),$D(IOF) W @IOF
    96         I $G(FIRSTIME),$G(MPIMB) D WARNING
    97         S FIRSTIME=0
    98         K DIFFS S NDIFFS=0
    99         S NLIN=IOSL-4
    100         I $D(MPIMB) S NLIN=NLIN-4,MPIMB=0
    101         I '$D(PACKAGE) S PACKAGE="PRIMARY"
    102         ;REM - modified next two lines to include IENs in review display
    103         W !,?30,$S(PACKAGE="PRIMARY":"RECORD1 [#"_REC1_"]",PACKAGE="LABORATORY":"MERGE FROM [#"_NAMIEN1_"]",1:"MERGE FROM [#"_REC1_"]")
    104         W ?55,$S(PACKAGE="PRIMARY":"RECORD2 [#"_REC2_"]",PACKAGE="LABORATORY":"MERGE TO [#"_NAMIEN2_"]",1:"MERGE TO [#"_REC2_"]")
    105         ;I FILE=63 W !?38,"[#"_NAMIEN1_"]",?55,"[#"_NAMIEN2_"]"
    106         W !,?30,$E(NAMREC1,1,20),?55,$E(NAMREC2,1,20)
    107         S NLIN=NLIN-2
    108         I $E(NAMREC1,21,40)'=""!($E(NAMREC2,21,40)'="") D
    109         . W !,?30,$E(NAMREC1,21,40),?55,$E(NAMREC2,21,40)
    110         . S NLIN=NLIN-1
    111         ;
    112         ;   add CMOR scores to header
    113         I $D(^DD(FILE,991.06)) D
    114         . W !,?30,"CMOR SCORE = "_$S($P($G(^DPT(REC1,"MPI")),U,6):$P(^DPT(REC1,"MPI"),U,6),1:"NULL"),?55,"CMOR SCORE = "_$S($P($G(^DPT(REC2,"MPI")),U,6):$P(^DPT(REC2,"MPI"),U,6),1:"NULL")
    115         . S NLIN=NLIN-1
    116         ;
    117         ;   add MULTIBLE BIRTH indicator to header
    118         S (REC1MB,REC2MB)=0
    119         I $G(^DPT(REC1,"MPIMB"))="Y" S REC1MB=1
    120         I $G(^DPT(REC2,"MPIMB"))="Y" S REC2MB=1
    121         I REC1MB!REC2MB D
    122         . W !,?30,$S(REC1MB:"**MULTIPLE BIRTH**",1:""),?55,$S(REC2MB:"**MULTIPLE BIRTH**",1:"")
    123         . S NLIN=NLIN-1
    124         ;
    125         W !,"----------------------------------------------------------------------------"
    126         S NLIN=NLIN-1
    127         Q
    128         ;
    129 POINT(VAL,FILE) ;
    130         N X,Y
    131         I +VAL'=VAL Q "BAD POINTER VALUE IN FILE"
    132         S Y=$G(^DIC(FILE,0,"GL")) Q:Y="" ""
    133         S Y=Y_VAL_",0)"
    134         S Y=$P($G(@Y),U) I Y'=""&($P(^DD(FILE,.01,0),U,2)["P") S Y=$$POINT(Y,+$P($P(^DD(FILE,.01,0),U,2),"P",2))
    135         S:Y="" Y="** Missing Entry in File "_FILE_"." ;REM - 9/6/96 When a pointer node is missing.
    136         Q Y
    137 TYPE(VAL,TYPE,DDNODE0,REC)      ;
    138         I TYPE["O",$D(^DD(FILE,FLD,2)) S Y=VAL,D0=REC X ^DD(FILE,FLD,2) S VAL=Y Q VAL
    139         I TYPE["F",VAL'="" S VAL=""""_VAL_"""" Q VAL
    140         I TYPE["P",VAL>0 S VAL=$$POINT(VAL,+$P(TYPE,"P",2)) Q VAL
    141         I TYPE["D",VAL>0 D  Q VAL
    142         . S VAL=$TR($$FMTE^XLFDT(VAL,2),"@"," ")
    143         I TYPE["S" D  Q VAL
    144         . N X S X=";"_$P(DDNODE0,U,3)
    145         . S X=$P($P(X,(";"_VAL_":"),2),";")
    146         . I X'="" S VAL=X
    147         Q VAL
    148         ;
    149 WARNING ;
    150         W !,?2,"*** WARNING!!!  One or both of these records indicated MULTIPLE BIRTH. ***",!,?2,"Use caution to ensure that these records are truly duplicates and not",!,?2,"siblings before proceeding.",!
    151         Q
     1XDRDSHOW ;SF-IRMFO.SEA/JLI - DISPLAY DATA IN FIELDS, GET OVERWRITES ;02/11/2004  08:56
     2 ;;7.3;TOOLKIT;**23,49,78**;Apr 25, 1995
     3 ;;
     4SHOW(FILE,REC1,REC2,FLDS,REVIEW) ;
     5 N FILDIC,MULT,DDVAL,NAMIEN1,NAMIEN2,NAMREC1,NAMREC2,FIRSTIME,MPIMB
     6 S FILDIC=$G(^DIC(FILE,0,"GL")) Q:FILDIC=""
     7 S REVIEW=+$G(REVIEW)
     8 S FILREC1=FILDIC_"REC1)"
     9 S FILREC2=FILDIC_"REC2)"
     10 S NAMREC1=$P($G(@FILREC1@(0)),U) I NAMREC1="" Q
     11 S NAMREC2=$P($G(@FILREC2@(0)),U) I NAMREC2="" Q
     12 I FILE=63 D
     13 . S NAMIEN1=+$P(@FILREC1@(0),U,3),NAMIEN2=+$P(@FILREC2@(0),U,3)
     14 . S NAMREC1=$P(^DPT(NAMIEN1,0),U),NAMREC2=$P(^DPT(NAMIEN2,0),U)
     15 I $P(^DD(FILE,.01,0),U,2)["P" D
     16 . N XFIL
     17 . S XFIL=+$P($P($G(^DD(FILE,.01,0)),U,2),"P",2) Q:XFIL'>0
     18 . S XFIL=$G(^DIC(XFIL,0,"GL")) Q:XFIL=""
     19 . S NAMREC1=$P(@(XFIL_NAMREC1_",0)"),U)
     20 . S NAMREC2=$P(@(XFIL_NAMREC2_",0)"),U)
     21 ;
     22 ;   recalc CMOR scores
     23 I FILE=2,$D(^DD(FILE,991.06)) D
     24 . N RGDFN S RGDFN=REC1 D CALC^RGVCCMR2
     25 . N RGDFN S RGDFN=REC2 D CALC^RGVCCMR2
     26 . Q
     27 ;
     28 ;   check for multiple birth indicator in MPI
     29 S FIRSTIME=1
     30 I FILE=2 D
     31 . I $G(^DPT(REC1,"MPIMB"))="Y"!($G(^DPT(REC2,"MPIMB"))="Y") S MPIMB=1
     32 . E  S MPIMB=0
     33 ;
     34 D HEADER
     35LOOP ;
     36 S FLD=0
     37 F FLD=0:0 S FLD=$O(^DD(FILE,FLD)) Q:FLD'>0  D  I NLIN<6 D PAGE Q:$D(DIRUT)  D HEADER
     38 . I FILE=63,$P($G(^DD(FILE,FLD,0)),U)="NAME" Q  ;scrn patient file data. From Lab
     39 . I FILE'=2,$P($G(^DD(FILE,FLD,0)),U,2)["P2" Q  ;From DINUM pointers.
     40 . S DDVAL=$G(^DD(FILE,FLD,0))
     41 . S NODE=$P($P(DDVAL,U,4),";")
     42 . S PIECE=$P($P(DDVAL,U,4),";",2)
     43 . I PIECE=0 S MULT(FLD)=""
     44 . I PIECE>0 D
     45 . . S X1=$P($G(@FILREC1@(NODE)),U,PIECE),X1=$$TYPE(X1,$P(DDVAL,U,2),DDVAL,REC1)
     46 . . S X2=$P($G(@FILREC2@(NODE)),U,PIECE),X2=$$TYPE(X2,$P(DDVAL,U,2),DDVAL,REC2)
     47 . . I X1'=""!(X2'="") D
     48 . . . S X0="    "
     49 . . . S XN=$P(DDVAL,U)
     50 . . . S XDRA=0
     51 . . . I X1'=""&(X2'=""),X1'=X2 S X0=$S($D(FLDS(FLD)):"||||",1:"****"),NDIFFS=NDIFFS+1,DIFFS(NDIFFS)=FLD,XDRA=1 I REVIEW S NLIN=NLIN-1
     52 . . . I 'REVIEW!XDRA D
     53 . . . . W ! S NLIN=NLIN-1
     54 . . . . F  Q:XN=""&(X1="")&(X2="")  D
     55 . . . . . W !,X0,"  ",$E(XN,1,20),?30,$E(X1,1,20),?55,$E(X2,1,20)
     56 . . . . . S NLIN=NLIN-1
     57 . . . . . S X0="    ",XN=$E(XN,21,$L(XN))
     58 . . . . . S X1=$E(X1,21,$L(X1))
     59 . . . . . S X2=$E(X2,21,$L(X2))
     60MULT I '$D(DIRUT) D
     61 . I $G(NDIFFS)>0 D PAGE Q:$D(DIRUT)  D HEADER
     62 . I $D(MULT) D
     63 . . F FLD=0:0 S FLD=$O(MULT(FLD)) Q:FLD'>0  D  I NLIN<6 D PAGE Q:$D(DIRUT)  D HEADER
     64 . . . S DDVAL=^DD(FILE,FLD,0)
     65 . . . S NAME=$P(DDVAL,U)
     66 . . . S NODE=$P($P(DDVAL,U,4),";")
     67 . . . S NOD1=$NA(@FILREC1@(NODE))
     68 . . . S NOD2=$NA(@FILREC2@(NODE))
     69 . . . S N1=0,N2=0
     70 . . . F I=0:0 S I=$O(@NOD1@(I)) Q:I'>0  S N1=N1+1
     71 . . . F I=0:0 S I=$O(@NOD2@(I)) Q:I'>0  S N2=N2+1
     72 . . . I N1'=0!(N2'=0) D
     73 . . . . S N1=$S(N1>1:N1_" entries",N1>0:N1_" entry",1:"---")
     74 . . . . S N2=$S(N2>1:N2_" entries",N2>0:N2_" entry",1:"---")
     75 . . . . W !!,$E(NAME,1,25),?30,N1,?55,N2
     76 . . . . S NLIN=NLIN-2
     77 Q
     78PAGE ;
     79 I IOST'["C-"!$D(ZTQUEUED) Q
     80 W !
     81 I '$D(DIFFS)!'REVIEW S DIR(0)="E" D ^DIR K DIR
     82 I $D(DIFFS)&REVIEW D
     83 . S DIR(0)="LO^1:"_NDIFFS,DIR("A")="OVERWRITE data for selected fields"
     84 . F I=1:1:NDIFFS W !,I,"  ",$P(^DD(FILE,DIFFS(I),0),U)
     85 . W ! D ^DIR K DIR
     86 . I X="",$D(DIRUT) K DIRUT
     87 . S I="" F  S I=$O(Y(I)) Q:I=""  S Y=Y(I) K Y(I) D
     88 . . F  Q:Y=","  Q:Y=""  S X=$D(FLDS(DIFFS(+Y))) K:X=1 FLDS(DIFFS(+Y)) S:X=0 FLDS(DIFFS(+Y))="" S Y=$P(Y,",",2,999)
     89 Q
     90 ;
     91HEADER ;
     92 N REC1MB,REC2MB
     93 I '$G(FIRSTIME),$D(IOF) W @IOF
     94 I $G(FIRSTIME),$G(MPIMB) D WARNING
     95 S FIRSTIME=0
     96 K DIFFS S NDIFFS=0
     97 S NLIN=IOSL-4
     98 I $D(MPIMB) S NLIN=NLIN-4,MPIMB=0
     99 I '$D(PACKAGE) S PACKAGE="PRIMARY"
     100 ;REM - modified next two lines to include IENs in review display
     101 W !,?30,$S(PACKAGE="PRIMARY":"RECORD1 [#"_REC1_"]",PACKAGE="LABORATORY":"MERGE FROM [#"_NAMIEN1_"]",1:"MERGE FROM [#"_REC1_"]")
     102 W ?55,$S(PACKAGE="PRIMARY":"RECORD2 [#"_REC2_"]",PACKAGE="LABORATORY":"MERGE TO [#"_NAMIEN2_"]",1:"MERGE TO [#"_REC2_"]")
     103 ;I FILE=63 W !?38,"[#"_NAMIEN1_"]",?55,"[#"_NAMIEN2_"]"
     104 W !,?30,$E(NAMREC1,1,20),?55,$E(NAMREC2,1,20)
     105 S NLIN=NLIN-2
     106 I $E(NAMREC1,21,40)'=""!($E(NAMREC2,21,40)'="") D
     107 . W !,?30,$E(NAMREC1,21,40),?55,$E(NAMREC2,21,40)
     108 . S NLIN=NLIN-1
     109 ;
     110 ;   add CMOR scores to header
     111 I $D(^DD(FILE,991.06)) D
     112 . W !,?30,"CMOR SCORE = "_$S($P($G(^DPT(REC1,"MPI")),U,6):$P(^DPT(REC1,"MPI"),U,6),1:"NULL"),?55,"CMOR SCORE = "_$S($P($G(^DPT(REC2,"MPI")),U,6):$P(^DPT(REC2,"MPI"),U,6),1:"NULL")
     113 . S NLIN=NLIN-1
     114 ;
     115 ;   add MULTIBLE BIRTH indicator to header
     116 S (REC1MB,REC2MB)=0
     117 I $G(^DPT(REC1,"MPIMB"))="Y" S REC1MB=1
     118 I $G(^DPT(REC2,"MPIMB"))="Y" S REC2MB=1
     119 I REC1MB!REC2MB D
     120 . W !,?30,$S(REC1MB:"**MULTIPLE BIRTH**",1:""),?55,$S(REC2MB:"**MULTIPLE BIRTH**",1:"")
     121 . S NLIN=NLIN-1
     122 ;
     123 W !,"----------------------------------------------------------------------------"
     124 S NLIN=NLIN-1
     125 Q
     126 ;
     127POINT(VAL,FILE) ;
     128 N X,Y
     129 I +VAL'=VAL Q "BAD POINTER VALUE IN FILE"
     130 S Y=$G(^DIC(FILE,0,"GL")) Q:Y="" ""
     131 S Y=Y_VAL_",0)"
     132 S Y=$P($G(@Y),U) I Y'=""&($P(^DD(FILE,.01,0),U,2)["P") S Y=$$POINT(Y,+$P($P(^DD(FILE,.01,0),U,2),"P",2))
     133 S:Y="" Y="** Missing Entry in File "_FILE_"." ;REM - 9/6/96 When a pointer node is missing.
     134 Q Y
     135TYPE(VAL,TYPE,DDNODE0,REC) ;
     136 I TYPE["O",$D(^DD(FILE,FLD,2)) S Y=VAL,D0=REC X ^DD(FILE,FLD,2) S VAL=Y Q VAL
     137 I TYPE["F",VAL'="" S VAL=""""_VAL_"""" Q VAL
     138 I TYPE["P",VAL>0 S VAL=$$POINT(VAL,+$P(TYPE,"P",2)) Q VAL
     139 I TYPE["D",VAL>0 D  Q VAL
     140 . S VAL=$TR($$FMTE^XLFDT(VAL,2),"@"," ")
     141 I TYPE["S" D  Q VAL
     142 . N X S X=";"_$P(DDNODE0,U,3)
     143 . S X=$P($P(X,(";"_VAL_":"),2),";")
     144 . I X'="" S VAL=X
     145 Q VAL
     146 ;
     147WARNING ;
     148 W !,?2,"*** WARNING!!!  One or both of these records indicated MULTIPLE BIRTH. ***",!,?2,"Use caution to ensure that these records are truly duplicates and not",!,?2,"siblings before proceeding.",!
     149 Q
Note: See TracChangeset for help on using the changeset viewer.