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
