XDRDSHOW ;SF-IRMFO.SEA/JLI - DISPLAY DATA IN FIELDS, GET OVERWRITES ;01/30/2008
;;7.3;TOOLKIT;**23,49,78,112,1017**;Apr 25, 1995;Build 3
;;
SHOW(FILE,REC1,REC2,FLDS,REVIEW) ;
N FILDIC,MULT,DDVAL,NAMIEN1,NAMIEN2,NAMREC1,NAMREC2,FIRSTIME,MPIMB
S FILDIC=$G(^DIC(FILE,0,"GL")) Q:FILDIC=""
S REVIEW=+$G(REVIEW)
S FILREC1=FILDIC_"REC1)"
S FILREC2=FILDIC_"REC2)"
S NAMREC1=$P($G(@FILREC1@(0)),U) I NAMREC1="" Q
S NAMREC2=$P($G(@FILREC2@(0)),U) I NAMREC2="" Q
I FILE=63 D
. S NAMIEN1=+$P(@FILREC1@(0),U,3),NAMIEN2=+$P(@FILREC2@(0),U,3)
. S NAMREC1=$P(^DPT(NAMIEN1,0),U),NAMREC2=$P(^DPT(NAMIEN2,0),U)
I $P(^DD(FILE,.01,0),U,2)["P" D
. N XFIL
. S XFIL=+$P($P($G(^DD(FILE,.01,0)),U,2),"P",2) Q:XFIL'>0
. S XFIL=$G(^DIC(XFIL,0,"GL")) Q:XFIL=""
. S NAMREC1=$P(@(XFIL_NAMREC1_",0)"),U)
. S NAMREC2=$P(@(XFIL_NAMREC2_",0)"),U)
;
; recalc CMOR scores
I FILE=2,$D(^DD(FILE,991.06)) D
. I '$L($T(CALC^RGVCCMR2)) Q ;XU*8.0*1017 - IHS/OIT/LJF 07/14/2006 PATCH 1003 check for existence of RGVCCMS2 routine
. N RGDFN S RGDFN=REC1 D CALC^RGVCCMR2
. N RGDFN S RGDFN=REC2 D CALC^RGVCCMR2
. Q
;
; check for multiple birth indicator in MPI
S FIRSTIME=1
I FILE=2 D
. I $G(^DPT(REC1,"MPIMB"))="Y"!($G(^DPT(REC2,"MPIMB"))="Y") S MPIMB=1
. E S MPIMB=0
;
D HEADER
LOOP ;
S FLD=0
F FLD=0:0 S FLD=$O(^DD(FILE,FLD)) Q:FLD'>0 D I NLIN<6 D PAGE Q:$D(DIRUT) D HEADER
. I FILE=63,$P($G(^DD(FILE,FLD,0)),U)="NAME" Q ;scrn patient file data. From Lab
. I FILE'=2,$P($G(^DD(FILE,FLD,0)),U,2)["P2" Q ;From DINUM pointers.
. S DDVAL=$G(^DD(FILE,FLD,0))
. S NODE=$P($P(DDVAL,U,4),";")
. S PIECE=$P($P(DDVAL,U,4),";",2)
. I PIECE=0 S MULT(FLD)=""
. I PIECE>0 D
. . S X1=$P($G(@FILREC1@(NODE)),U,PIECE),X1=$$TYPE(X1,$P(DDVAL,U,2),DDVAL,REC1)
. . S X2=$P($G(@FILREC2@(NODE)),U,PIECE),X2=$$TYPE(X2,$P(DDVAL,U,2),DDVAL,REC2)
. . I X1'=""!(X2'="") D
. . . S X0=" "
. . . S XN=$P(DDVAL,U)
. . . S XDRA=0
. . . I X1'=""&(X2'=""),X1'=X2 D
. . . . I FILE=2,((FLD=991.01)!(FLD=991.02)) Q ;jds restrict ICN overwrites for MPI
. . . . S X0=$S($D(FLDS(FLD)):"||||",1:"****"),NDIFFS=NDIFFS+1,DIFFS(NDIFFS)=FLD,XDRA=1 I REVIEW S NLIN=NLIN-1
. . . I 'REVIEW!XDRA D
. . . . W ! S NLIN=NLIN-1
. . . . F Q:XN=""&(X1="")&(X2="") D
. . . . . W !,X0," ",$E(XN,1,20),?30,$E(X1,1,20),?55,$E(X2,1,20)
. . . . . S NLIN=NLIN-1
. . . . . S X0=" ",XN=$E(XN,21,$L(XN))
. . . . . S X1=$E(X1,21,$L(X1))
. . . . . S X2=$E(X2,21,$L(X2))
MULT I '$D(DIRUT) D
. I $G(NDIFFS)>0 D PAGE Q:$D(DIRUT) D HEADER
. I $D(MULT) D
. . F FLD=0:0 S FLD=$O(MULT(FLD)) Q:FLD'>0 D I NLIN<6 D PAGE Q:$D(DIRUT) D HEADER
. . . S DDVAL=^DD(FILE,FLD,0)
. . . S NAME=$P(DDVAL,U)
. . . S NODE=$P($P(DDVAL,U,4),";")
. . . S NOD1=$NA(@FILREC1@(NODE))
. . . S NOD2=$NA(@FILREC2@(NODE))
. . . S N1=0,N2=0
. . . F I=0:0 S I=$O(@NOD1@(I)) Q:I'>0 S N1=N1+1
. . . F I=0:0 S I=$O(@NOD2@(I)) Q:I'>0 S N2=N2+1
. . . I N1'=0!(N2'=0) D
. . . . S N1=$S(N1>1:N1_" entries",N1>0:N1_" entry",1:"---")
. . . . S N2=$S(N2>1:N2_" entries",N2>0:N2_" entry",1:"---")
. . . . W !!,$E(NAME,1,25),?30,N1,?55,N2
. . . . S NLIN=NLIN-2
Q
PAGE ;
I IOST'["C-"!$D(ZTQUEUED) Q
W !
I '$D(DIFFS)!'REVIEW S DIR(0)="E" D ^DIR K DIR
I $D(DIFFS)&REVIEW D
. S DIR(0)="LO^1:"_NDIFFS,DIR("A")="OVERWRITE data for selected fields"
. F I=1:1:NDIFFS W !,I," ",$P(^DD(FILE,DIFFS(I),0),U)
. W ! D ^DIR K DIR
. I X="",$D(DIRUT) K DIRUT
. S I="" F S I=$O(Y(I)) Q:I="" S Y=Y(I) K Y(I) D
. . 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)
Q
;
N REC1MB,REC2MB
I '$G(FIRSTIME),$D(IOF) W @IOF
I $G(FIRSTIME),$G(MPIMB) D WARNING
S FIRSTIME=0
K DIFFS S NDIFFS=0
S NLIN=IOSL-4
I $D(MPIMB) S NLIN=NLIN-4,MPIMB=0
I '$D(PACKAGE) S PACKAGE="PRIMARY"
;REM - modified next two lines to include IENs in review display
W !,?30,$S(PACKAGE="PRIMARY":"RECORD1 [#"_REC1_"]",PACKAGE="LABORATORY":"MERGE FROM [#"_NAMIEN1_"]",1:"MERGE FROM [#"_REC1_"]")
W ?55,$S(PACKAGE="PRIMARY":"RECORD2 [#"_REC2_"]",PACKAGE="LABORATORY":"MERGE TO [#"_NAMIEN2_"]",1:"MERGE TO [#"_REC2_"]")
;I FILE=63 W !?38,"[#"_NAMIEN1_"]",?55,"[#"_NAMIEN2_"]"
W !,?30,$E(NAMREC1,1,20),?55,$E(NAMREC2,1,20)
S NLIN=NLIN-2
I $E(NAMREC1,21,40)'=""!($E(NAMREC2,21,40)'="") D
. W !,?30,$E(NAMREC1,21,40),?55,$E(NAMREC2,21,40)
. S NLIN=NLIN-1
;
; add CMOR scores to header
I $D(^DD(FILE,991.06)) D
. 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")
. S NLIN=NLIN-1
;
; add MULTIBLE BIRTH indicator to header
S (REC1MB,REC2MB)=0
I $G(^DPT(REC1,"MPIMB"))="Y" S REC1MB=1
I $G(^DPT(REC2,"MPIMB"))="Y" S REC2MB=1
I REC1MB!REC2MB D
. W !,?30,$S(REC1MB:"**MULTIPLE BIRTH**",1:""),?55,$S(REC2MB:"**MULTIPLE BIRTH**",1:"")
. S NLIN=NLIN-1
;
W !,"----------------------------------------------------------------------------"
S NLIN=NLIN-1
Q
;
POINT(VAL,FILE) ;
N X,Y
I +VAL'=VAL Q "BAD POINTER VALUE IN FILE"
S Y=$G(^DIC(FILE,0,"GL")) Q:Y="" ""
S Y=Y_VAL_",0)"
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))
S:Y="" Y="** Missing Entry in File "_FILE_"." ;REM - 9/6/96 When a pointer node is missing.
Q Y
TYPE(VAL,TYPE,DDNODE0,REC) ;
I TYPE["O",$D(^DD(FILE,FLD,2)) S Y=VAL,D0=REC X ^DD(FILE,FLD,2) S VAL=Y Q VAL
I TYPE["F",VAL'="" S VAL=""""_VAL_"""" Q VAL
I TYPE["P",VAL>0 S VAL=$$POINT(VAL,+$P(TYPE,"P",2)) Q VAL
I TYPE["D",VAL>0 D Q VAL
. S VAL=$TR($$FMTE^XLFDT(VAL,2),"@"," ")
I TYPE["S" D Q VAL
. N X S X=";"_$P(DDNODE0,U,3)
. S X=$P($P(X,(";"_VAL_":"),2),";")
. I X'="" S VAL=X
Q VAL
;
WARNING ;
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.",!
Q
XDRDSHOW ;SF-IRMFO.SEA/JLI - DISPLAY DATA IN FIELDS, GET OVERWRITES ;01/30/2008
+1 ;;7.3;TOOLKIT;**23,49,78,112,1017**;Apr 25, 1995;Build 3
+2 ;;
SHOW(FILE,REC1,REC2,FLDS,REVIEW) ;
+1 NEW FILDIC,MULT,DDVAL,NAMIEN1,NAMIEN2,NAMREC1,NAMREC2,FIRSTIME,MPIMB
+2 SET FILDIC=$GET(^DIC(FILE,0,"GL"))
IF FILDIC=""
QUIT
+3 SET REVIEW=+$GET(REVIEW)
+4 SET FILREC1=FILDIC_"REC1)"
+5 SET FILREC2=FILDIC_"REC2)"
+6 SET NAMREC1=$PIECE($GET(@FILREC1@(0)),U)
IF NAMREC1=""
QUIT
+7 SET NAMREC2=$PIECE($GET(@FILREC2@(0)),U)
IF NAMREC2=""
QUIT
+8 IF FILE=63
Begin DoDot:1
+9 SET NAMIEN1=+$PIECE(@FILREC1@(0),U,3)
SET NAMIEN2=+$PIECE(@FILREC2@(0),U,3)
+10 SET NAMREC1=$PIECE(^DPT(NAMIEN1,0),U)
SET NAMREC2=$PIECE(^DPT(NAMIEN2,0),U)
End DoDot:1
+11 IF $PIECE(^DD(FILE,.01,0),U,2)["P"
Begin DoDot:1
+12 NEW XFIL
+13 SET XFIL=+$PIECE($PIECE($GET(^DD(FILE,.01,0)),U,2),"P",2)
IF XFIL'>0
QUIT
+14 SET XFIL=$GET(^DIC(XFIL,0,"GL"))
IF XFIL=""
QUIT
+15 SET NAMREC1=$PIECE(@(XFIL_NAMREC1_",0)"),U)
+16 SET NAMREC2=$PIECE(@(XFIL_NAMREC2_",0)"),U)
End DoDot:1
+17 ;
+18 ; recalc CMOR scores
+19 IF FILE=2
IF $DATA(^DD(FILE,991.06))
Begin DoDot:1
+20 ;XU*8.0*1017 - IHS/OIT/LJF 07/14/2006 PATCH 1003 check for existence of RGVCCMS2 routine
IF '$LENGTH($TEXT(CALC^RGVCCMR2))
QUIT
+21 NEW RGDFN
SET RGDFN=REC1
DO CALC^RGVCCMR2
+22 NEW RGDFN
SET RGDFN=REC2
DO CALC^RGVCCMR2
+23 QUIT
End DoDot:1
+24 ;
+25 ; check for multiple birth indicator in MPI
+26 SET FIRSTIME=1
+27 IF FILE=2
Begin DoDot:1
+28 IF $GET(^DPT(REC1,"MPIMB"))="Y"!($GET(^DPT(REC2,"MPIMB"))="Y")
SET MPIMB=1
+29 IF '$TEST
SET MPIMB=0
End DoDot:1
+30 ;
+31 DO HEADER
LOOP ;
+1 SET FLD=0
+2 FOR FLD=0:0
SET FLD=$ORDER(^DD(FILE,FLD))
IF FLD'>0
QUIT
Begin DoDot:1
+3 ;scrn patient file data. From Lab
IF FILE=63
IF $PIECE($GET(^DD(FILE,FLD,0)),U)="NAME"
QUIT
+4 ;From DINUM pointers.
IF FILE'=2
IF $PIECE($GET(^DD(FILE,FLD,0)),U,2)["P2"
QUIT
+5 SET DDVAL=$GET(^DD(FILE,FLD,0))
+6 SET NODE=$PIECE($PIECE(DDVAL,U,4),";")
+7 SET PIECE=$PIECE($PIECE(DDVAL,U,4),";",2)
+8 IF PIECE=0
SET MULT(FLD)=""
+9 IF PIECE>0
Begin DoDot:2
+10 SET X1=$PIECE($GET(@FILREC1@(NODE)),U,PIECE)
SET X1=$$TYPE(X1,$PIECE(DDVAL,U,2),DDVAL,REC1)
+11 SET X2=$PIECE($GET(@FILREC2@(NODE)),U,PIECE)
SET X2=$$TYPE(X2,$PIECE(DDVAL,U,2),DDVAL,REC2)
+12 IF X1'=""!(X2'="")
Begin DoDot:3
+13 SET X0=" "
+14 SET XN=$PIECE(DDVAL,U)
+15 SET XDRA=0
+16 IF X1'=""&(X2'="")
IF X1'=X2
Begin DoDot:4
+17 ;jds restrict ICN overwrites for MPI
IF FILE=2
IF ((FLD=991.01)!(FLD=991.02))
QUIT
+18 SET X0=$SELECT($DATA(FLDS(FLD)):"||||",1:"****")
SET NDIFFS=NDIFFS+1
SET DIFFS(NDIFFS)=FLD
SET XDRA=1
IF REVIEW
SET NLIN=NLIN-1
End DoDot:4
+19 IF 'REVIEW!XDRA
Begin DoDot:4
+20 WRITE !
SET NLIN=NLIN-1
+21 FOR
IF XN=""&(X1="")&(X2="")
QUIT
Begin DoDot:5
+22 WRITE !,X0," ",$EXTRACT(XN,1,20),?30,$EXTRACT(X1,1,20),?55,$EXTRACT(X2,1,20)
+23 SET NLIN=NLIN-1
+24 SET X0=" "
SET XN=$EXTRACT(XN,21,$LENGTH(XN))
+25 SET X1=$EXTRACT(X1,21,$LENGTH(X1))
+26 SET X2=$EXTRACT(X2,21,$LENGTH(X2))
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
IF NLIN<6
DO PAGE
IF $DATA(DIRUT)
QUIT
DO HEADER
MULT IF '$DATA(DIRUT)
Begin DoDot:1
+1 IF $GET(NDIFFS)>0
DO PAGE
IF $DATA(DIRUT)
QUIT
DO HEADER
+2 IF $DATA(MULT)
Begin DoDot:2
+3 FOR FLD=0:0
SET FLD=$ORDER(MULT(FLD))
IF FLD'>0
QUIT
Begin DoDot:3
+4 SET DDVAL=^DD(FILE,FLD,0)
+5 SET NAME=$PIECE(DDVAL,U)
+6 SET NODE=$PIECE($PIECE(DDVAL,U,4),";")
+7 SET NOD1=$NAME(@FILREC1@(NODE))
+8 SET NOD2=$NAME(@FILREC2@(NODE))
+9 SET N1=0
SET N2=0
+10 FOR I=0:0
SET I=$ORDER(@NOD1@(I))
IF I'>0
QUIT
SET N1=N1+1
+11 FOR I=0:0
SET I=$ORDER(@NOD2@(I))
IF I'>0
QUIT
SET N2=N2+1
+12 IF N1'=0!(N2'=0)
Begin DoDot:4
+13 SET N1=$SELECT(N1>1:N1_" entries",N1>0:N1_" entry",1:"---")
+14 SET N2=$SELECT(N2>1:N2_" entries",N2>0:N2_" entry",1:"---")
+15 WRITE !!,$EXTRACT(NAME,1,25),?30,N1,?55,N2
+16 SET NLIN=NLIN-2
End DoDot:4
End DoDot:3
IF NLIN<6
DO PAGE
IF $DATA(DIRUT)
QUIT
DO HEADER
End DoDot:2
End DoDot:1
+17 QUIT
PAGE ;
+1 IF IOST'["C-"!$DATA(ZTQUEUED)
QUIT
+2 WRITE !
+3 IF '$DATA(DIFFS)!'REVIEW
SET DIR(0)="E"
DO ^DIR
KILL DIR
+4 IF $DATA(DIFFS)&REVIEW
Begin DoDot:1
+5 SET DIR(0)="LO^1:"_NDIFFS
SET DIR("A")="OVERWRITE data for selected fields"
+6 FOR I=1:1:NDIFFS
WRITE !,I," ",$PIECE(^DD(FILE,DIFFS(I),0),U)
+7 WRITE !
DO ^DIR
KILL DIR
+8 IF X=""
IF $DATA(DIRUT)
KILL DIRUT
+9 SET I=""
FOR
SET I=$ORDER(Y(I))
IF I=""
QUIT
SET Y=Y(I)
KILL Y(I)
Begin DoDot:2
+10 FOR
IF Y=","
QUIT
IF Y=""
QUIT
SET X=$DATA(FLDS(DIFFS(+Y)))
IF X=1
KILL FLDS(DIFFS(+Y))
IF X=0
SET FLDS(DIFFS(+Y))=""
SET Y=$PIECE(Y,",",2,999)
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
+1 NEW REC1MB,REC2MB
+2 IF '$GET(FIRSTIME)
IF $DATA(IOF)
WRITE @IOF
+3 IF $GET(FIRSTIME)
IF $GET(MPIMB)
DO WARNING
+4 SET FIRSTIME=0
+5 KILL DIFFS
SET NDIFFS=0
+6 SET NLIN=IOSL-4
+7 IF $DATA(MPIMB)
SET NLIN=NLIN-4
SET MPIMB=0
+8 IF '$DATA(PACKAGE)
SET PACKAGE="PRIMARY"
+9 ;REM - modified next two lines to include IENs in review display
+10 WRITE !,?30,$SELECT(PACKAGE="PRIMARY":"RECORD1 [#"_REC1_"]",PACKAGE="LABORATORY":"MERGE FROM [#"_NAMIEN1_"]",1:"MERGE FROM [#"_REC1_"]")
+11 WRITE ?55,$SELECT(PACKAGE="PRIMARY":"RECORD2 [#"_REC2_"]",PACKAGE="LABORATORY":"MERGE TO [#"_NAMIEN2_"]",1:"MERGE TO [#"_REC2_"]")
+12 ;I FILE=63 W !?38,"[#"_NAMIEN1_"]",?55,"[#"_NAMIEN2_"]"
+13 WRITE !,?30,$EXTRACT(NAMREC1,1,20),?55,$EXTRACT(NAMREC2,1,20)
+14 SET NLIN=NLIN-2
+15 IF $EXTRACT(NAMREC1,21,40)'=""!($EXTRACT(NAMREC2,21,40)'="")
Begin DoDot:1
+16 WRITE !,?30,$EXTRACT(NAMREC1,21,40),?55,$EXTRACT(NAMREC2,21,40)
+17 SET NLIN=NLIN-1
End DoDot:1
+18 ;
+19 ; add CMOR scores to header
+20 IF $DATA(^DD(FILE,991.06))
Begin DoDot:1
+21 WRITE !,?30,"CMOR SCORE = "_$SELECT($PIECE($GET(^DPT(REC1,"MPI")),U,6):$PIECE(^DPT(REC1,"MPI"),U,6),1:"NULL"),?55,"CMOR SCORE = "_$SELECT($PIECE($GET(^DPT(REC2,"MPI")),U,6):$PIECE(^DPT(REC2,"MPI"),U,6),1:"NULL")
+22 SET NLIN=NLIN-1
End DoDot:1
+23 ;
+24 ; add MULTIBLE BIRTH indicator to header
+25 SET (REC1MB,REC2MB)=0
+26 IF $GET(^DPT(REC1,"MPIMB"))="Y"
SET REC1MB=1
+27 IF $GET(^DPT(REC2,"MPIMB"))="Y"
SET REC2MB=1
+28 IF REC1MB!REC2MB
Begin DoDot:1
+29 WRITE !,?30,$SELECT(REC1MB:"**MULTIPLE BIRTH**",1:""),?55,$SELECT(REC2MB:"**MULTIPLE BIRTH**",1:"")
+30 SET NLIN=NLIN-1
End DoDot:1
+31 ;
+32 WRITE !,"----------------------------------------------------------------------------"
+33 SET NLIN=NLIN-1
+34 QUIT
+35 ;
POINT(VAL,FILE) ;
+1 NEW X,Y
+2 IF +VAL'=VAL
QUIT "BAD POINTER VALUE IN FILE"
+3 SET Y=$GET(^DIC(FILE,0,"GL"))
IF Y=""
QUIT ""
+4 SET Y=Y_VAL_",0)"
+5 SET Y=$PIECE($GET(@Y),U)
IF Y'=""&($PIECE(^DD(FILE,.01,0),U,2)["P")
SET Y=$$POINT(Y,+$PIECE($PIECE(^DD(FILE,.01,0),U,2),"P",2))
+6 ;REM - 9/6/96 When a pointer node is missing.
IF Y=""
SET Y="** Missing Entry in File "_FILE_"."
+7 QUIT Y
TYPE(VAL,TYPE,DDNODE0,REC) ;
+1 IF TYPE["O"
IF $DATA(^DD(FILE,FLD,2))
SET Y=VAL
SET D0=REC
XECUTE ^DD(FILE,FLD,2)
SET VAL=Y
QUIT VAL
+2 IF TYPE["F"
IF VAL'=""
SET VAL=""""_VAL_""""
QUIT VAL
+3 IF TYPE["P"
IF VAL>0
SET VAL=$$POINT(VAL,+$PIECE(TYPE,"P",2))
QUIT VAL
+4 IF TYPE["D"
IF VAL>0
Begin DoDot:1
+5 SET VAL=$TRANSLATE($$FMTE^XLFDT(VAL,2),"@"," ")
End DoDot:1
QUIT VAL
+6 IF TYPE["S"
Begin DoDot:1
+7 NEW X
SET X=";"_$PIECE(DDNODE0,U,3)
+8 SET X=$PIECE($PIECE(X,(";"_VAL_":"),2),";")
+9 IF X'=""
SET VAL=X
End DoDot:1
QUIT VAL
+10 QUIT VAL
+11 ;
WARNING ;
+1 WRITE !,?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.",!
+2 QUIT
