- XDRDSHOW ;SF-IRMFO.SEA/JLI - DISPLAY DATA IN FIELDS, GET OVERWRITES ; Jun 23, 2022@08:57:56
- ;;7.3;TOOLKIT;**23,49,78,112,154**;Apr 25, 1995;Build 8
- ;;
- SHOW(FILE,REC1,REC2,FLDS,REVIEW) ;
- I $G(REC1)="" Q ;Ba added to fix INC22413387
- I $G(REC2)="" Q ;Ba added
- I $G(FILE)="" Q ;Ba added
- W !!!
- 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
- . 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXDRDSHOW 6077 printed Jan 18, 2025@03:40:22 Page 2
- XDRDSHOW ;SF-IRMFO.SEA/JLI - DISPLAY DATA IN FIELDS, GET OVERWRITES ; Jun 23, 2022@08:57:56
- +1 ;;7.3;TOOLKIT;**23,49,78,112,154**;Apr 25, 1995;Build 8
- +2 ;;
- SHOW(FILE,REC1,REC2,FLDS,REVIEW) ;
- +1 ;Ba added to fix INC22413387
- IF $GET(REC1)=""
- QUIT
- +2 ;Ba added
- IF $GET(REC2)=""
- QUIT
- +3 ;Ba added
- IF $GET(FILE)=""
- QUIT
- +4 WRITE !!!
- +5 NEW FILDIC,MULT,DDVAL,NAMIEN1,NAMIEN2,NAMREC1,NAMREC2,FIRSTIME,MPIMB
- +6 SET FILDIC=$GET(^DIC(FILE,0,"GL"))
- if FILDIC=""
- QUIT
- +7 SET REVIEW=+$GET(REVIEW)
- +8 SET FILREC1=FILDIC_"REC1)"
- +9 SET FILREC2=FILDIC_"REC2)"
- +10 SET NAMREC1=$PIECE($GET(@FILREC1@(0)),U)
- IF NAMREC1=""
- QUIT
- +11 SET NAMREC2=$PIECE($GET(@FILREC2@(0)),U)
- IF NAMREC2=""
- QUIT
- +12 IF FILE=63
- Begin DoDot:1
- +13 SET NAMIEN1=+$PIECE(@FILREC1@(0),U,3)
- SET NAMIEN2=+$PIECE(@FILREC2@(0),U,3)
- +14 SET NAMREC1=$PIECE(^DPT(NAMIEN1,0),U)
- SET NAMREC2=$PIECE(^DPT(NAMIEN2,0),U)
- End DoDot:1
- +15 IF $PIECE(^DD(FILE,.01,0),U,2)["P"
- Begin DoDot:1
- +16 NEW XFIL
- +17 SET XFIL=+$PIECE($PIECE($GET(^DD(FILE,.01,0)),U,2),"P",2)
- if XFIL'>0
- QUIT
- +18 SET XFIL=$GET(^DIC(XFIL,0,"GL"))
- if XFIL=""
- QUIT
- +19 SET NAMREC1=$PIECE(@(XFIL_NAMREC1_",0)"),U)
- +20 SET NAMREC2=$PIECE(@(XFIL_NAMREC2_",0)"),U)
- End DoDot:1
- +21 ;
- +22 ; recalc CMOR scores
- +23 IF FILE=2
- IF $DATA(^DD(FILE,991.06))
- Begin DoDot:1
- +24 NEW RGDFN
- SET RGDFN=REC1
- DO CALC^RGVCCMR2
- +25 NEW RGDFN
- SET RGDFN=REC2
- DO CALC^RGVCCMR2
- +26 QUIT
- End DoDot:1
- +27 ;
- +28 ; check for multiple birth indicator in MPI
- +29 SET FIRSTIME=1
- +30 IF FILE=2
- Begin DoDot:1
- +31 IF $GET(^DPT(REC1,"MPIMB"))="Y"!($GET(^DPT(REC2,"MPIMB"))="Y")
- SET MPIMB=1
- +32 IF '$TEST
- SET MPIMB=0
- End DoDot:1
- +33 ;
- +34 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