BPMKIDS.m

BPMKIDS ;IHS/OIT/LJF - PRE INSTALL & ENVIRON CHECK

 ;;1.0;IHS PATIENT MERGE;;MAR 01, 2010

 ;Contains several subroutines written by Anne Fugatt, Phx Area Office

 ;

CKENV ; environment check code

 ;Prevents "Disable Options..." and "Move Routines..." questions

 S XPDDIQ("XPZ1")=0,XPPDIQ("XPZ2")=0

 ;

 ;CHECKS FOR PACKAGES AND PATCHES HERE

 NEW PATCH S PATCH="APSP*7.0*1004"

 I ($O(^PSRX(0))),('$$PATCH^XPDUTL(PATCH)) D

 . W !,"You must first install "_PATCH_"." S XPDQUIT=2

 ;

 S PATCH="LR*5.2*1024"

 I ($O(^LAB(60,0))),('$$PATCH^XPDUTL(PATCH)) D

 . W !,"You must first install "_PATCH_"." S XPDQUIT=2

 ;

 ;IHS/OIT/ENM 02/03/2010 THE FOLLOWING CODE WAS DISABLED AND FIXED BELOW

 ;S PATCH="BQI*1.0*3"

 ;I $O(^BQICARE(0)),('$$PATCH^XPDUTL(PATCH)) D

 ;. W !,"You must first install "_PATCH_"." S XPDQUIT=2

 ;IHS/OIT/ENM 02/03/2010

 I $O(^BQICARE(0)),+$$VERSION^XPDUTL("BQI")<1.1 D

 . W !,"You must first install iCare Version 1.1 or Greater." S XPDQUIT=2

 Q

 ;

PRE ;EP;

 ; clean out old AXDR entry in Package file

 NEW DA,DIK

 S DA=$O(^DIC(9.4,"C","AXDR",0)) Q:'DA

 S DIK="^DIC(9.4,"

 D ^DIK

 Q

 ;

POST ;EP; post init subroutine

 D SITE,PKG,DIKZ55,CHS,DUPTEST,XPAR,OLDMRG,ZEROS,POS323

 Q

 ;

SITE ;----- EDIT SITE PARAMETERS ;IHS/PHXAO/AEF

 ;SETS 'DAYS BEFORE FINAL VERIFY' AND 'DAYS BETWEEN VERIFY AND MERGE'

 ;TO ZERO IN THE DUPLICATE RESOLUTION FILE #15.1

 ;

 D BMES^XPDUTL("EDITING DUPLICATE RESOLUTION SITE PARAMETERS")

 ;

 N DA,DIE,DR,FILE,X,Y

 ;

 S FILE=0

 F  S FILE=$O(^VA(15.1,FILE)) Q:'FILE  D

 . S DIE="^VA(15.1,"

 . S DA=FILE

 . S DR=".13////0;.14////0;1.03///180"

 . D ^DIE

 ;

 Q

 ;

PKG ;----- CLEAN UP PACKAGE FILE ;IHS/PHXAO/AEF

 ;

 D BMES^XPDUTL("CLEANING UP PACKAGE FILE...")

 ;

 ;----- CLEAN UP ENTRIES WITH MISSING ZERO NODES

 D BMES^XPDUTL("CLEANING UP ENTRIES WITH MISSING ZERO NODES...")

 N DA,DIK,IEN,X,Y

 S IEN=0

 F  S IEN=$O(^DIC(9.4,IEN)) Q:'IEN  D

 . Q:$D(^DIC(9.4,IEN,0))

 . S DIK="^DIC(9.4,"

 . S DA=IEN

 . D ^DIK

 . D BMES^XPDUTL(IEN)

 ;

 ;----- CLEAN UP AFFECTS REC0RD MERGE MULTIPLE

 N IEN

 D BMES^XPDUTL("CLEANING UP 'AFFECTS RECORD MERGE' MULTIPLE...")

 S IEN=0

 F  S IEN=$O(^DIC(9.4,IEN)) Q:'IEN  D

 . K ^DIC(9.4,IEN,20)

 ;

 ; Now clean up AMRG xref ;IHS/OIT/LJF

 K ^DIC(9.4,"AMRG")

 NEW DIK,DA S DIK="^DIC(9.4,DA(1),20,",DIK(1)=".01^AMRG"

 S DA(1)=0

 F  S DA(1)=$O(^DIC(9.4,DA(1))) Q:'DA(1)  D ENALL^DIK

 ;

 Q

 ;

DIKZ55 ;----- FIXING PHARMACY PATIENT FILE #55 TO WORK WITH MERGE

 ; released with APSP patch 1005 but not called during install

 ; it also recompiles all xrefs for the file

 D BMES^XPDUTL("Removing duplicate xref 9999999902 in Pharmacy Patient File.")

 D DELIX^DDMOD(55.03,.01,999999902,"W")

 ;

 Q

 ;

CHS ;----- REINDEX "AC" XREF ON PATIENT FIELD OF THE TRANSACTION RECORD;IHS/PAO/AEF

 ;      SUBFIELD OF THE DOCUMENT SUBFIELD OF THE CHS FACILITY FILE

 ;

 N BPMDA1,BPMDA2,DA,DIK,X,Y

 ;

 D BMES^XPDUTL("Re-indexing the ""AC"" xref in the CHS Facility file...")

 ;

 S BPMDA2=0

 F  S BPMDA2=$O(^ACHSF(BPMDA2)) Q:'BPMDA2  D

 . S BPMDA1=0

 . F  S BPMDA1=$O(^ACHSF(BPMDA2,"D",BPMDA1)) Q:'BPMDA1  D

 . . S DA(1)=BPMDA1

 . . S DA(2)=BPMDA2

 . . S DIK="^ACHSF("_DA(2)_",""D"","_DA(1)_",""T"","

 . . S DIK(1)="2^AC"

 . . D ENALL^DIK

 Q

 ;

DUPTEST ; stuff Duplicate Tests multiple in file 15.1

 ; may contain old uncertified merge calls so replacing whole subfile

 D BMES^XPDUTL("Updating Duplicate Tests Logic")

 ;

 NEW DA,DIK,DIC,DLAYGO,DIE,DR,X,Y,BPMN

 ; first delete everything in multiple

 S DIK="^VA(15.1,2,11,",DA(1)=2

 S BPMN=0 F  S BPMN=$O(^VA(15.1,2,11,BPMN)) Q:'BPMN  S DA=BPMN D ^DIK

 ;

 ; now add in the current logic

 S DIC="^VA(15.1,2,11,",DA(1)=2,DIC(0)="L",DLAYGO=15.111

 F BPMN=1:1:9 D

 . S X=$P($T(TESTS+BPMN),";;",2) K DD,DO D FILE^DICN Q:'Y

 . S DIE=DIC,DA=+Y

 . S DR=".02///"_$P($T(TESTS+BPMN),";;",3)_";.03///"_$P($T(TESTS+BPMN),";;",4)_";.04///"_$P($T(TESTS+BPMN),";;",5)

 . S DR=DR_";.05///"_$P($T(TESTS+BPMN),";;",6)_";.06///"_$P($T(TESTS+BPMN),";;",7)_";.07///"_$P($T(TESTS+BPMN),";;",8)

 . D ^DIE

 Q

 ;

XPAR ; add an instance of BPM USE IHS LOGIC parameter

 D BMES^XPDUTL("Adding IHS parameter BPM USE IHS LOGIC")

 D ADD^XPAR("PKG","BPM USE IHS LOGIC",1,1)

 D CHG^XPAR("PKG","BPM USE IHS LOGIC",1,1)

 Q

 ;

OLDMRG ; clean up databases if old merge software used

 ; need to add -9 nodes and remove "B" cross-references

 D BMES^XPDUTL("Cleaning up old patient merge entries")

 NEW NAME,DFN

 S NAME="*"

 F  S NAME=$O(^DPT("B",NAME)) Q:NAME'["*"  D

 . S DFN=0 F  S DFN=$O(^DPT("B",NAME,DFN)) Q:'DFN  D

 . . Q:$P($G(^DPT(DFN,0)),U,19)<1    ;not an old merge

 . . ;Q:$G(^DPT(DFN,-9))              ;already has -9 node

 . . S ^DPT(DFN,-9)=$P(^DPT(DFN,0),U,19)

 . . S ^AUPNPAT(DFN,-9)=^DPT(DFN,-9)

 . . K ^DPT("B",NAME,DFN)

 . . K ^AUPNPAT("B",DFN,DFN)

 Q

 ;

ZEROS ; clean up globals with extra zero nodes

 D BMES^XPDUTL("Cleaning up extra zero nodes in RPMS globals")

 NEW FILE,GLB,FAC,X,NODE

 S FILE=1

 F  S FILE=$O(^DIC(FILE)) Q:'FILE  D

 . S GLB=$G(^DIC(FILE,0,"GL")) Q:GLB=""  Q:GLB["^DIC"

 . S GLB=GLB_"0)"

 . ;

 . ; look for non-standard globals

 . I GLB["DUZ(2)" D  Q

 . . S GLB=$P(GLB,"(",1)

 . . S FAC=0 F  S FAC=$O(@GLB@(FAC)) Q:'FAC  Q:'$D(^AUTTLOC(FAC,0))  D

 . . . S GLB=GLB_"("_FAC_",0)"

 . . . S X="" F  S X=$O(@GLB@(X)) Q:X=""  D

 . . . . D BMES^XPDUTL("Deleting "_$P(GLB,")",1)_","_X_")")

 . . . . S NODE=$P(GLB,")",1)_","_$S(X=+X:X,1:""""_X_"""")_")" K @NODE

 . . . S GLB=$P(GLB,"(",1)

 . ;

 . ; process normal globals

 . S X="" F  S X=$O(@GLB@(X)) Q:X=""  D

 . . D BMES^XPDUTL("Deleting "_$P(GLB,")",1)_","_X_")")

 . . S NODE=$P(GLB,")",1)_","_$S(X:X,1:""""_X_"""")_")" K @NODE

 Q

 ;

POS323 ; clean out data in field .323 in file 2

 ;IHS does not use PERIOD OF SERVICE field but there is old data there

 D BMES^XPDUTL("Cleaning out old Period of Service data")

 NEW DFN

 S DFN=0 F  S DFN=$O(^DPT(DFN)) Q:'DFN  D

 . Q:$P($G(^DPT(DFN,.32)),U,3)=""    ;skip if no data

 . S $P(^DPT(DFN,.32),U,3)="" W "."

 Q

 ;

TESTS ;;

 ;;NAME;;1;;XDRPTN;;2;;.01;;100;;-60

 ;;SSN;;5;;XDRPTSSN;;2;;.09;;100;;-60

 ;;SEX;;10;;XDRPTSX;;2;;.02;;20;;-90

 ;;DATE OF DEATH;;20;;XDRPTDOD;;2;;.351;;50;;-50

 ;;MOTHER'S MAIDEN NAME;;25;;XDRPTMMN;;2;;.2403;;50;;-90

 ;;LAST SEPARATION DATE;;31;;XDRPTLSD;;2;;.327;;50;;-40

 ;;CLAIM NUMBER;;32;;XDRPTCLN;;2;;.313;;80;;-60

 ;;DATE OF BIRTH;;17;;XDRPTDOB;;2;;.03;;60;;-40

 ;;TRIBE OF MEMBERSHIP;;7;;BPMPTTR;;9000001;;1108;;5;;-5

BPMKIDS   ;IHS/OIT/LJF - PRE INSTALL & ENVIRON CHECK

 +1       ;;1.0;IHS PATIENT MERGE;;MAR 01, 2010

 +2       ;Contains several subroutines written by Anne Fugatt, Phx Area Office

 +3       ;

CKENV     ; environment check code

 +1       ;Prevents "Disable Options..." and "Move Routines..." questions

 +2        SET XPDDIQ("XPZ1")=0

           SET XPPDIQ("XPZ2")=0

 +3       ;

 +4       ;CHECKS FOR PACKAGES AND PATCHES HERE

 +5        NEW PATCH

           SET PATCH="APSP*7.0*1004"

 +6        IF ($ORDER(^PSRX(0)))

               IF ('$$PATCH^XPDUTL(PATCH))

                   Begin DoDot:1

 +7                    WRITE !,"You must first install "_PATCH_"."

                       SET XPDQUIT=2

                   End DoDot:1

 +8       ;

 +9        SET PATCH="LR*5.2*1024"

 +10       IF ($ORDER(^LAB(60,0)))

               IF ('$$PATCH^XPDUTL(PATCH))

                   Begin DoDot:1

 +11                   WRITE !,"You must first install "_PATCH_"."

                       SET XPDQUIT=2

                   End DoDot:1

 +12      ;

 +13      ;IHS/OIT/ENM 02/03/2010 THE FOLLOWING CODE WAS DISABLED AND FIXED BELOW

 +14      ;S PATCH="BQI*1.0*3"

 +15      ;I $O(^BQICARE(0)),('$$PATCH^XPDUTL(PATCH)) D

 +16      ;. W !,"You must first install "_PATCH_"." S XPDQUIT=2

 +17      ;IHS/OIT/ENM 02/03/2010

 +18       IF $ORDER(^BQICARE(0))

               IF +$$VERSION^XPDUTL("BQI")<1.1

                   Begin DoDot:1

 +19                   WRITE !,"You must first install iCare Version 1.1 or Greater."

                       SET XPDQUIT=2

                   End DoDot:1

 +20       QUIT 

 +21      ;

PRE       ;EP;

 +1       ; clean out old AXDR entry in Package file

 +2        NEW DA,DIK

 +3        SET DA=$ORDER(^DIC(9.4,"C","AXDR",0))

           IF 'DA

               QUIT 

 +4        SET DIK="^DIC(9.4,"

 +5        DO ^DIK

 +6        QUIT 

 +7       ;

POST      ;EP; post init subroutine

 +1        DO SITE

           DO PKG

           DO DIKZ55

           DO CHS

           DO DUPTEST

           DO XPAR

           DO OLDMRG

           DO ZEROS

           DO POS323

 +2        QUIT 

 +3       ;

SITE      ;----- EDIT SITE PARAMETERS ;IHS/PHXAO/AEF

 +1       ;SETS 'DAYS BEFORE FINAL VERIFY' AND 'DAYS BETWEEN VERIFY AND MERGE'

 +2       ;TO ZERO IN THE DUPLICATE RESOLUTION FILE #15.1

 +3       ;

 +4        DO BMES^XPDUTL("EDITING DUPLICATE RESOLUTION SITE PARAMETERS")

 +5       ;

 +6        NEW DA,DIE,DR,FILE,X,Y

 +7       ;

 +8        SET FILE=0

 +9        FOR 

               SET FILE=$ORDER(^VA(15.1,FILE))

               IF 'FILE

                   QUIT 

               Begin DoDot:1

 +10               SET DIE="^VA(15.1,"

 +11               SET DA=FILE

 +12               SET DR=".13////0;.14////0;1.03///180"

 +13               DO ^DIE

               End DoDot:1

 +14      ;

 +15       QUIT 

 +16      ;

PKG       ;----- CLEAN UP PACKAGE FILE ;IHS/PHXAO/AEF

 +1       ;

 +2        DO BMES^XPDUTL("CLEANING UP PACKAGE FILE...")

 +3       ;

 +4       ;----- CLEAN UP ENTRIES WITH MISSING ZERO NODES

 +5        DO BMES^XPDUTL("CLEANING UP ENTRIES WITH MISSING ZERO NODES...")

 +6        NEW DA,DIK,IEN,X,Y

 +7        SET IEN=0

 +8        FOR 

               SET IEN=$ORDER(^DIC(9.4,IEN))

               IF 'IEN

                   QUIT 

               Begin DoDot:1

 +9                IF $DATA(^DIC(9.4,IEN,0))

                       QUIT 

 +10               SET DIK="^DIC(9.4,"

 +11               SET DA=IEN

 +12               DO ^DIK

 +13               DO BMES^XPDUTL(IEN)

               End DoDot:1

 +14      ;

 +15      ;----- CLEAN UP AFFECTS REC0RD MERGE MULTIPLE

 +16       NEW IEN

 +17       DO BMES^XPDUTL("CLEANING UP 'AFFECTS RECORD MERGE' MULTIPLE...")

 +18       SET IEN=0

 +19       FOR 

               SET IEN=$ORDER(^DIC(9.4,IEN))

               IF 'IEN

                   QUIT 

               Begin DoDot:1

 +20               KILL ^DIC(9.4,IEN,20)

               End DoDot:1

 +21      ;

 +22      ; Now clean up AMRG xref ;IHS/OIT/LJF

 +23       KILL ^DIC(9.4,"AMRG")

 +24       NEW DIK,DA

           SET DIK="^DIC(9.4,DA(1),20,"

           SET DIK(1)=".01^AMRG"

 +25       SET DA(1)=0

 +26       FOR 

               SET DA(1)=$ORDER(^DIC(9.4,DA(1)))

               IF 'DA(1)

                   QUIT 

               DO ENALL^DIK

 +27      ;

 +28       QUIT 

 +29      ;

DIKZ55    ;----- FIXING PHARMACY PATIENT FILE #55 TO WORK WITH MERGE

 +1       ; released with APSP patch 1005 but not called during install

 +2       ; it also recompiles all xrefs for the file

 +3        DO BMES^XPDUTL("Removing duplicate xref 9999999902 in Pharmacy Patient File.")

 +4        DO DELIX^DDMOD(55.03,.01,999999902,"W")

 +5       ;

 +6        QUIT 

 +7       ;

CHS       ;----- REINDEX "AC" XREF ON PATIENT FIELD OF THE TRANSACTION RECORD;IHS/PAO/AEF

 +1       ;      SUBFIELD OF THE DOCUMENT SUBFIELD OF THE CHS FACILITY FILE

 +2       ;

 +3        NEW BPMDA1,BPMDA2,DA,DIK,X,Y

 +4       ;

 +5        DO BMES^XPDUTL("Re-indexing the ""AC"" xref in the CHS Facility file...")

 +6       ;

 +7        SET BPMDA2=0

 +8        FOR 

               SET BPMDA2=$ORDER(^ACHSF(BPMDA2))

               IF 'BPMDA2

                   QUIT 

               Begin DoDot:1

 +9                SET BPMDA1=0

 +10               FOR 

                       SET BPMDA1=$ORDER(^ACHSF(BPMDA2,"D",BPMDA1))

                       IF 'BPMDA1

                           QUIT 

                       Begin DoDot:2

 +11                       SET DA(1)=BPMDA1

 +12                       SET DA(2)=BPMDA2

 +13                       SET DIK="^ACHSF("_DA(2)_",""D"","_DA(1)_",""T"","

 +14                       SET DIK(1)="2^AC"

 +15                       DO ENALL^DIK

                       End DoDot:2

               End DoDot:1

 +16       QUIT 

 +17      ;

DUPTEST   ; stuff Duplicate Tests multiple in file 15.1

 +1       ; may contain old uncertified merge calls so replacing whole subfile

 +2        DO BMES^XPDUTL("Updating Duplicate Tests Logic")

 +3       ;

 +4        NEW DA,DIK,DIC,DLAYGO,DIE,DR,X,Y,BPMN

 +5       ; first delete everything in multiple

 +6        SET DIK="^VA(15.1,2,11,"

           SET DA(1)=2

 +7        SET BPMN=0

           FOR 

               SET BPMN=$ORDER(^VA(15.1,2,11,BPMN))

               IF 'BPMN

                   QUIT 

               SET DA=BPMN

               DO ^DIK

 +8       ;

 +9       ; now add in the current logic

 +10       SET DIC="^VA(15.1,2,11,"

           SET DA(1)=2

           SET DIC(0)="L"

           SET DLAYGO=15.111

 +11       FOR BPMN=1:1:9

               Begin DoDot:1

 +12               SET X=$PIECE($TEXT(TESTS+BPMN),";;",2)

                   KILL DD,DO

                   DO FILE^DICN

                   IF 'Y

                       QUIT 

 +13               SET DIE=DIC

                   SET DA=+Y

 +14               SET DR=".02///"_$PIECE($TEXT(TESTS+BPMN),";;",3)_";.03///"_$PIECE($TEXT(TESTS+BPMN),";;",4)_";.04///"_$PIECE($TEXT(TESTS+BPMN),";;",5)

 +15               SET DR=DR_";.05///"_$PIECE($TEXT(TESTS+BPMN),";;",6)_";.06///"_$PIECE($TEXT(TESTS+BPMN),";;",7)_";.07///"_$PIECE($TEXT(TESTS+BPMN),";;",8)

 +16               DO ^DIE

               End DoDot:1

 +17       QUIT 

 +18      ;

XPAR      ; add an instance of BPM USE IHS LOGIC parameter

 +1        DO BMES^XPDUTL("Adding IHS parameter BPM USE IHS LOGIC")

 +2        DO ADD^XPAR("PKG","BPM USE IHS LOGIC",1,1)

 +3        DO CHG^XPAR("PKG","BPM USE IHS LOGIC",1,1)

 +4        QUIT 

 +5       ;

OLDMRG    ; clean up databases if old merge software used

 +1       ; need to add -9 nodes and remove "B" cross-references

 +2        DO BMES^XPDUTL("Cleaning up old patient merge entries")

 +3        NEW NAME,DFN

 +4        SET NAME="*"

 +5        FOR 

               SET NAME=$ORDER(^DPT("B",NAME))

               IF NAME'["*"

                   QUIT 

               Begin DoDot:1

 +6                SET DFN=0

                   FOR 

                       SET DFN=$ORDER(^DPT("B",NAME,DFN))

                       IF 'DFN

                           QUIT 

                       Begin DoDot:2

 +7       ;not an old merge

                           IF $PIECE($GET(^DPT(DFN,0)),U,19)<1

                               QUIT 

 +8       ;Q:$G(^DPT(DFN,-9))              ;already has -9 node

 +9                        SET ^DPT(DFN,-9)=$PIECE(^DPT(DFN,0),U,19)

 +10                       SET ^AUPNPAT(DFN,-9)=^DPT(DFN,-9)

 +11                       KILL ^DPT("B",NAME,DFN)

 +12                       KILL ^AUPNPAT("B",DFN,DFN)

                       End DoDot:2

               End DoDot:1

 +13       QUIT 

 +14      ;

ZEROS     ; clean up globals with extra zero nodes

 +1        DO BMES^XPDUTL("Cleaning up extra zero nodes in RPMS globals")

 +2        NEW FILE,GLB,FAC,X,NODE

 +3        SET FILE=1

 +4        FOR 

               SET FILE=$ORDER(^DIC(FILE))

               IF 'FILE

                   QUIT 

               Begin DoDot:1

 +5                SET GLB=$GET(^DIC(FILE,0,"GL"))

                   IF GLB=""

                       QUIT 

                   IF GLB["^DIC"

                       QUIT 

 +6                SET GLB=GLB_"0)"

 +7       ;

 +8       ; look for non-standard globals

 +9                IF GLB["DUZ(2)"

                       Begin DoDot:2

 +10                       SET GLB=$PIECE(GLB,"(",1)

 +11                       SET FAC=0

                           FOR 

                               SET FAC=$ORDER(@GLB@(FAC))

                               IF 'FAC

                                   QUIT 

                               IF '$DATA(^AUTTLOC(FAC,0))

                                   QUIT 

                               Begin DoDot:3

 +12                               SET GLB=GLB_"("_FAC_",0)"

 +13                               SET X=""

                                   FOR 

                                       SET X=$ORDER(@GLB@(X))

                                       IF X=""

                                           QUIT 

                                       Begin DoDot:4

 +14                                       DO BMES^XPDUTL("Deleting "_$PIECE(GLB,")",1)_","_X_")")

 +15                                       SET NODE=$PIECE(GLB,")",1)_","_$SELECT(X=+X:X,1:""""_X_"""")_")"

                                           KILL @NODE

                                       End DoDot:4

 +16                               SET GLB=$PIECE(GLB,"(",1)

                               End DoDot:3

                       End DoDot:2

                       QUIT 

 +17      ;

 +18      ; process normal globals

 +19               SET X=""

                   FOR 

                       SET X=$ORDER(@GLB@(X))

                       IF X=""

                           QUIT 

                       Begin DoDot:2

 +20                       DO BMES^XPDUTL("Deleting "_$PIECE(GLB,")",1)_","_X_")")

 +21                       SET NODE=$PIECE(GLB,")",1)_","_$SELECT(X:X,1:""""_X_"""")_")"

                           KILL @NODE

                       End DoDot:2

               End DoDot:1

 +22       QUIT 

 +23      ;

POS323    ; clean out data in field .323 in file 2

 +1       ;IHS does not use PERIOD OF SERVICE field but there is old data there

 +2        DO BMES^XPDUTL("Cleaning out old Period of Service data")

 +3        NEW DFN

 +4        SET DFN=0

           FOR 

               SET DFN=$ORDER(^DPT(DFN))

               IF 'DFN

                   QUIT 

               Begin DoDot:1

 +5       ;skip if no data

                   IF $PIECE($GET(^DPT(DFN,.32)),U,3)=""

                       QUIT 

 +6                SET $PIECE(^DPT(DFN,.32),U,3)=""

                   WRITE "."

               End DoDot:1

 +7        QUIT 

 +8       ;

TESTS     ;;

 +1       ;;NAME;;1;;XDRPTN;;2;;.01;;100;;-60

 +2       ;;SSN;;5;;XDRPTSSN;;2;;.09;;100;;-60

 +3       ;;SEX;;10;;XDRPTSX;;2;;.02;;20;;-90

 +4       ;;DATE OF DEATH;;20;;XDRPTDOD;;2;;.351;;50;;-50

 +5       ;;MOTHER'S MAIDEN NAME;;25;;XDRPTMMN;;2;;.2403;;50;;-90

 +6       ;;LAST SEPARATION DATE;;31;;XDRPTLSD;;2;;.327;;50;;-40

 +7       ;;CLAIM NUMBER;;32;;XDRPTCLN;;2;;.313;;80;;-60

 +8       ;;DATE OF BIRTH;;17;;XDRPTDOB;;2;;.03;;60;;-40

 +9       ;;TRIBE OF MEMBERSHIP;;7;;BPMPTTR;;9000001;;1108;;5;;-5