BRNP01 ; IHS/OIT/LJF - PRE & POST INIT CODE FOR PATCH 1
;;2.0;RELEASE OF INFO SYSTEM;*1*;APR 10, 2003
;IHS/OIT/LJF 10/11/2007 PATCH 1 Added this routine
;
CHKEN ;
I '$G(IOM) D HOME^%ZIS
I '$G(DUZ) W !,"DUZ UNDEFINED OR 0." S XPDQUIT=2 Q
I '$L($G(DUZ(0))) W !,"DUZ(0) UNDEFINED OR NULL." S XPDQUIT=2 Q
;
;Prevents "Disable Options..." and "Move Routines..." questions
S XPDDIQ("XPZ1")=0,XPPDIQ("XPZ2")=0
;
;CHECKS FOR PACKAGES AND PATCHES HERE
I $$VERSION^XPDUTL("IHS RELEASE OF INFORMATION")<2 D
. W !,"You must first install IHS RELEASE OF INFORMATION V2.0." S XPDQUIT=2
;
Q
;
PRE ;EP; pre-init code
D BMES^XPDUTL("Removing triggers for Suspend Date fields.")
D DELIX^DDMOD(90264,2402,1),DELIX^DDMOD(90264,2403,1)
Q
;
POST ;EP; post init code
;D FIX ;TEMPORARY FOR TEST SITES ONLY
D ACTIVE,XREF,RPTMENU,FAC
Q
;
ACTIVE ; set all current ROI LISTING REC PARTY entries as Active
D BMES^XPDUTL("Stuffing ACTIVE for all ROI LISTING REC PARTY entries")
NEW BRN,DIE,DA,DR
S DIE=90264.1,DR=".08///A"
S BRN=0 F S BRN=$O(^BRNTREQ(BRN)) Q:'BRN D
. Q:$P(^BRNTREQ(BRN,0),U,8)]"" ;skip if already answered
. S DA=BRN D ^DIE
Q
;
XREF ; reindex ROI LISTING RECORD file
; make sure all new and fixed indices are in good shape
D BMES^XPDUTL("Re-indexing ROI LISTING RECORD file for selected indices.")
K ^BRNREC("AA"),^BRNREC("AC"),^BRNREC("AD"),^BRNREC("AP")
NEW DIK S DIK="^BRNREC(",DIK(1)=".01^AA1^AC1^AD1^AP1^AF1^AG1" D ENALL^DIK
S DIK(1)=".22^AJ" D ENALL^DIK
Q
;
D BMES^XPDUTL("Removing old Aging Report option from Menu.")
NEW OPT,MENU,ITEM,DIK,DA
S OPT=$O(^DIC(19,"B","BRN GS AGING1 RPT",0)) I 'OPT D ERR Q
S MENU=$O(^DIC(19,"B","BRN MENU RPT",0)) I 'MENU D ERR Q
S ITM=$O(^DIC(19,MENU,10,"B",OPT,0)) I 'ITM Q
S DA=ITM,DA(1)=MENU,DIK="^DIC(19,"_DA(1)_",10,"
D ^DIK
Q
;
ERR ; report error if action could not be performed
D BMES^XPDUTL(" **** ERROR REPORTED: Could not remove option. ****")
Q
;
FAC ; stuff new facility field where possible
; This code will attempt to determine the facility involved for
; each past disclosure. If the site has only one facility set up
; in the parameter file, that will be stuffed. For sites with more
; than one facility, the code will try to match on patient, user who
; initiated, staff assignment or user who completed. If none match
; exactly, the field will be left blank.
;
D BMES^XPDUTL("Stuffing new FACILITY field based on site parameter.")
NEW FAC,BRN,PAT,HRCN,FOUND,SAV,USER
S FAC=$O(^BRNPARM("B",0)) Q:'FAC
I '$O(^BRNPARM("B",FAC)) D ONEFAC(FAC) Q ;one facility in site parameter file
;
;now for multiple site databases
; loop through ROI file
S BRN=0 F S BRN=$O(^BRNREC(BRN)) Q:'BRN D
. ;Q:$$GET1^DIQ(90264,BRN,.22)]"" ;already has facility set
. S PAT=$P(^BRNREC(BRN,0),U,3) Q:'PAT ;get patient
. K HRCN S FAC=0 F S FAC=$O(^AUPNPAT(PAT,41,FAC)) Q:'FAC S HRCN(FAC)="" ;get chart #s
. S (FOUND,FAC)=0 K SAV
. F S FAC=$O(^BRNPARM("B",FAC)) Q:'FAC I $D(HRCN(FAC)) S FOUND=FOUND+1 S:FOUND=1 SAV=FAC
. I FOUND=1 D STUFFAC(BRN,SAV) Q ;only one match found, so okay to stuff value
. ;
. ; else try matching on user's division
. S USER=$P(^BRNREC(BRN,0),U,12) Q:'USER ;get user who initiated
. S (FOUND,FAC)=0 K SAV
. F S FAC=$O(^BRNPARM("B",FAC)) Q:'FAC I $D(^VA(200,USER,2,FAC)) S FOUND=FOUND+1 S:FOUND=1 SAV=FAC
. I FOUND=1 D STUFFAC(BRN,SAV)
Q
;
ONEFAC(FAC) ; stuff all entries with the one facility in the site parameter file
NEW IEN S IEN=$O(^BRNPARM("B",FAC,0)) Q:'IEN
Q:'$$ACTIVFAC^BRNU(IEN) ;quit if no longer active
NEW BRN,DIE,DR,DA
S DIE="^BRNREC(",DR=".22////"_IEN
S BRN=0 F S BRN=$O(^BRNREC(BRN)) Q:'BRN D
. ;Q:$$GET1^DIQ(90264,BRN,.22)]"" ;already has facility set
. S DA=BRN D ^DIE
Q
;
STUFFAC(DA,FAC) ; stuff this entry with this facility
NEW IEN S IEN=$O(^BRNPARM("B",FAC,0)) Q:'IEN
Q:'$$ACTIVFAC^BRNU(IEN) ;quit if no longer active
NEW DIE,DR
S DIE="^BRNREC(",DR=".22////"_IEN
D ^DIE
Q
;
FIX ; fix test sites for trigger problems on reindexing
NEW BRN,BRN1,LIST
S BRN=0 F S BRN=$O(^BRNREC(BRN)) Q:'BRN D
. K LIST
. S BRN1=0 S BRN1=$O(^BRNREC(BRN,23,BRN1)) Q:'BRN1 D
. . Q:'$D(^BRNREC(BRN,23,BRN1,0))
. . S LIST(BRN1)=^BRNREC(BRN,23,BRN1,0)
. ;
. NEW OPEN,CLOSED,DATE,LAST
. S LAST="",CLOSED=""
. S BRN1=0 F S BRN1=$O(LIST(BRN1)) Q:'BRN1 D
. . S OPEN=$G(OPEN)+1 ;count entry
. . S DATE=$P(LIST(BRN1),U,2) I (DATE]""),(DATE>LAST) S LAST=DATE
. . I DATE]"" S CLOSED=$G(CLOSED)+1 ;count closed
. ;
. I OPEN]"" D ;data found to update
. . S $P(^BRNREC(BRN,0),U,25,26)=OPEN_U_CLOSED
. . I OPEN=CLOSED S $P(^BRNREC(BRN,0),U,8)="C" D
. . . I LAST]"" S $P(^BRNREC(BRN,0),U,19)=LAST
Q
BRNP01 ; IHS/OIT/LJF - PRE & POST INIT CODE FOR PATCH 1
+1 ;;2.0;RELEASE OF INFO SYSTEM;*1*;APR 10, 2003
+2 ;IHS/OIT/LJF 10/11/2007 PATCH 1 Added this routine
+3 ;
CHKEN ;
+1 IF '$GET(IOM)
DO HOME^%ZIS
+2 IF '$GET(DUZ)
WRITE !,"DUZ UNDEFINED OR 0."
SET XPDQUIT=2
QUIT
+3 IF '$LENGTH($GET(DUZ(0)))
WRITE !,"DUZ(0) UNDEFINED OR NULL."
SET XPDQUIT=2
QUIT
+4 ;
+5 ;Prevents "Disable Options..." and "Move Routines..." questions
+6 SET XPDDIQ("XPZ1")=0
SET XPPDIQ("XPZ2")=0
+7 ;
+8 ;CHECKS FOR PACKAGES AND PATCHES HERE
+9 IF $$VERSION^XPDUTL("IHS RELEASE OF INFORMATION")<2
Begin DoDot:1
+10 WRITE !,"You must first install IHS RELEASE OF INFORMATION V2.0."
SET XPDQUIT=2
End DoDot:1
+11 ;
+12 QUIT
+13 ;
PRE ;EP; pre-init code
+1 DO BMES^XPDUTL("Removing triggers for Suspend Date fields.")
+2 DO DELIX^DDMOD(90264,2402,1)
DO DELIX^DDMOD(90264,2403,1)
+3 QUIT
+4 ;
POST ;EP; post init code
+1 ;D FIX ;TEMPORARY FOR TEST SITES ONLY
+2 DO ACTIVE
DO XREF
DO RPTMENU
DO FAC
+3 QUIT
+4 ;
ACTIVE ; set all current ROI LISTING REC PARTY entries as Active
+1 DO BMES^XPDUTL("Stuffing ACTIVE for all ROI LISTING REC PARTY entries")
+2 NEW BRN,DIE,DA,DR
+3 SET DIE=90264.1
SET DR=".08///A"
+4 SET BRN=0
FOR
SET BRN=$ORDER(^BRNTREQ(BRN))
IF 'BRN
QUIT
Begin DoDot:1
+5 ;skip if already answered
IF $PIECE(^BRNTREQ(BRN,0),U,8)]""
QUIT
+6 SET DA=BRN
DO ^DIE
End DoDot:1
+7 QUIT
+8 ;
XREF ; reindex ROI LISTING RECORD file
+1 ; make sure all new and fixed indices are in good shape
+2 DO BMES^XPDUTL("Re-indexing ROI LISTING RECORD file for selected indices.")
+3 KILL ^BRNREC("AA"),^BRNREC("AC"),^BRNREC("AD"),^BRNREC("AP")
+4 NEW DIK
SET DIK="^BRNREC("
SET DIK(1)=".01^AA1^AC1^AD1^AP1^AF1^AG1"
DO ENALL^DIK
+5 SET DIK(1)=".22^AJ"
DO ENALL^DIK
+6 QUIT
+7 ;
+1 DO BMES^XPDUTL("Removing old Aging Report option from Menu.")
+2 NEW OPT,MENU,ITEM,DIK,DA
+3 SET OPT=$ORDER(^DIC(19,"B","BRN GS AGING1 RPT",0))
IF 'OPT
DO ERR
QUIT
+4 SET MENU=$ORDER(^DIC(19,"B","BRN MENU RPT",0))
IF 'MENU
DO ERR
QUIT
+5 SET ITM=$ORDER(^DIC(19,MENU,10,"B",OPT,0))
IF 'ITM
QUIT
+6 SET DA=ITM
SET DA(1)=MENU
SET DIK="^DIC(19,"_DA(1)_",10,"
+7 DO ^DIK
+8 QUIT
+9 ;
ERR ; report error if action could not be performed
+1 DO BMES^XPDUTL(" **** ERROR REPORTED: Could not remove option. ****")
+2 QUIT
+3 ;
FAC ; stuff new facility field where possible
+1 ; This code will attempt to determine the facility involved for
+2 ; each past disclosure. If the site has only one facility set up
+3 ; in the parameter file, that will be stuffed. For sites with more
+4 ; than one facility, the code will try to match on patient, user who
+5 ; initiated, staff assignment or user who completed. If none match
+6 ; exactly, the field will be left blank.
+7 ;
+8 DO BMES^XPDUTL("Stuffing new FACILITY field based on site parameter.")
+9 NEW FAC,BRN,PAT,HRCN,FOUND,SAV,USER
+10 SET FAC=$ORDER(^BRNPARM("B",0))
IF 'FAC
QUIT
+11 ;one facility in site parameter file
IF '$ORDER(^BRNPARM("B",FAC))
DO ONEFAC(FAC)
QUIT
+12 ;
+13 ;now for multiple site databases
+14 ; loop through ROI file
+15 SET BRN=0
FOR
SET BRN=$ORDER(^BRNREC(BRN))
IF 'BRN
QUIT
Begin DoDot:1
+16 ;Q:$$GET1^DIQ(90264,BRN,.22)]"" ;already has facility set
+17 ;get patient
SET PAT=$PIECE(^BRNREC(BRN,0),U,3)
IF 'PAT
QUIT
+18 ;get chart #s
KILL HRCN
SET FAC=0
FOR
SET FAC=$ORDER(^AUPNPAT(PAT,41,FAC))
IF 'FAC
QUIT
SET HRCN(FAC)=""
+19 SET (FOUND,FAC)=0
KILL SAV
+20 FOR
SET FAC=$ORDER(^BRNPARM("B",FAC))
IF 'FAC
QUIT
IF $DATA(HRCN(FAC))
SET FOUND=FOUND+1
IF FOUND=1
SET SAV=FAC
+21 ;only one match found, so okay to stuff value
IF FOUND=1
DO STUFFAC(BRN,SAV)
QUIT
+22 ;
+23 ; else try matching on user's division
+24 ;get user who initiated
SET USER=$PIECE(^BRNREC(BRN,0),U,12)
IF 'USER
QUIT
+25 SET (FOUND,FAC)=0
KILL SAV
+26 FOR
SET FAC=$ORDER(^BRNPARM("B",FAC))
IF 'FAC
QUIT
IF $DATA(^VA(200,USER,2,FAC))
SET FOUND=FOUND+1
IF FOUND=1
SET SAV=FAC
+27 IF FOUND=1
DO STUFFAC(BRN,SAV)
End DoDot:1
+28 QUIT
+29 ;
ONEFAC(FAC) ; stuff all entries with the one facility in the site parameter file
+1 NEW IEN
SET IEN=$ORDER(^BRNPARM("B",FAC,0))
IF 'IEN
QUIT
+2 ;quit if no longer active
IF '$$ACTIVFAC^BRNU(IEN)
QUIT
+3 NEW BRN,DIE,DR,DA
+4 SET DIE="^BRNREC("
SET DR=".22////"_IEN
+5 SET BRN=0
FOR
SET BRN=$ORDER(^BRNREC(BRN))
IF 'BRN
QUIT
Begin DoDot:1
+6 ;Q:$$GET1^DIQ(90264,BRN,.22)]"" ;already has facility set
+7 SET DA=BRN
DO ^DIE
End DoDot:1
+8 QUIT
+9 ;
STUFFAC(DA,FAC) ; stuff this entry with this facility
+1 NEW IEN
SET IEN=$ORDER(^BRNPARM("B",FAC,0))
IF 'IEN
QUIT
+2 ;quit if no longer active
IF '$$ACTIVFAC^BRNU(IEN)
QUIT
+3 NEW DIE,DR
+4 SET DIE="^BRNREC("
SET DR=".22////"_IEN
+5 DO ^DIE
+6 QUIT
+7 ;
FIX ; fix test sites for trigger problems on reindexing
+1 NEW BRN,BRN1,LIST
+2 SET BRN=0
FOR
SET BRN=$ORDER(^BRNREC(BRN))
IF 'BRN
QUIT
Begin DoDot:1
+3 KILL LIST
+4 SET BRN1=0
SET BRN1=$ORDER(^BRNREC(BRN,23,BRN1))
IF 'BRN1
QUIT
Begin DoDot:2
+5 IF '$DATA(^BRNREC(BRN,23,BRN1,0))
QUIT
+6 SET LIST(BRN1)=^BRNREC(BRN,23,BRN1,0)
End DoDot:2
+7 ;
+8 NEW OPEN,CLOSED,DATE,LAST
+9 SET LAST=""
SET CLOSED=""
+10 SET BRN1=0
FOR
SET BRN1=$ORDER(LIST(BRN1))
IF 'BRN1
QUIT
Begin DoDot:2
+11 ;count entry
SET OPEN=$GET(OPEN)+1
+12 SET DATE=$PIECE(LIST(BRN1),U,2)
IF (DATE]"")
IF (DATE>LAST)
SET LAST=DATE
+13 ;count closed
IF DATE]""
SET CLOSED=$GET(CLOSED)+1
End DoDot:2
+14 ;
+15 ;data found to update
IF OPEN]""
Begin DoDot:2
+16 SET $PIECE(^BRNREC(BRN,0),U,25,26)=OPEN_U_CLOSED
+17 IF OPEN=CLOSED
SET $PIECE(^BRNREC(BRN,0),U,8)="C"
Begin DoDot:3
+18 IF LAST]""
SET $PIECE(^BRNREC(BRN,0),U,19)=LAST
End DoDot:3
End DoDot:2
End DoDot:1
+19 QUIT
