Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BRNP01

BRNP01.m

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