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

PXRMEXFI.m

Go to the documentation of this file. 
  1. PXRMEXFI ;SLC/PKR/PJH - Exchange utilities for file entries. ;17-Apr-2018 12:06;DU
  1.  ;;2.0;CLINICAL REMINDERS;**6,1001,12,18,24,26,1005,1009**;Feb 04, 2005;Build 17
  1.  ;IHS/MSC/MGH Patch 1001 Restrict file entries that IHS cannot create
  1.  ;==============================================
  1. DELALL(FILENUM,NAME) ;Delete all file entries named NAME.
  1.  N IEN,IND,LIST,MSG
  1.  D FIND^DIC(FILENUM,"","@","KU",NAME,"*","","","","LIST","MSG")
  1.  I $P(LIST("DILIST",0),U,1)=0 Q
  1.  S IND=0
  1.  F  S IND=$O(LIST("DILIST",2,IND)) Q:IND=""  D
  1.  . S IEN=LIST("DILIST",2,IND)
  1.  . D DELETE(FILENUM,IEN)
  1.  Q
  1.  ;
  1.  ;==============================================
  1. DELETE(FILENUM,DA) ;Delete a file entry.
  1.  N DIK
  1.  S DIK=$$ROOT^DILFD(FILENUM)
  1.  D ^DIK
  1.  Q
  1.  ;
  1.  ;==============================================
  1. FEIMSG(SAME,ATTR) ;Output the general file exists install message.
  1.  N IND,NOUT,TEXT,TEXTO
  1.  S TEXT(1)=ATTR("FILE NAME")_" entry named "_ATTR("NAME")_" already exists"
  1.  I SAME D
  1.  . S TEXT(2)="and the packed component is identical, skipping."
  1.  . S TEXT(3)=" "
  1.  . D FORMAT^PXRMTEXT(1,70,3,.TEXT,.NOUT,.TEXTO)
  1.  . F IND=1:1:NOUT W !,TEXTO(IND)
  1.  . H 1
  1.  I 'SAME D
  1.  . S TEXT(2)="but the packed component is different, what do you want to do?"
  1.  . D FORMAT^PXRMTEXT(1,70,2,.TEXT,.NOUT,.TEXTO)
  1.  . F IND=1:1:NOUT W !,TEXTO(IND)
  1.  Q
  1.  ;
  1.  ;==============================================
  1. FOKTT(FILENUM) ;Check if it is ok to transport items from this file.
  1.  ;
  1.  I $G(PXRMIGDS) Q 1
  1.  ;If a file has been standardized do not transport it.
  1.  ;DBIA #4640
  1.  I $P($$GETSTAT^HDISVF01(FILENUM),U,1)>0 Q 0
  1.  ;
  1.  ;Drugs not allowed.
  1.  I FILENUM=50 Q 0
  1.  ;
  1.  ;VA Generic not allowed.
  1.  I FILENUM=50.6 Q 0
  1.  ;
  1.  ;VA Drug Class not allowed.
  1.  I FILENUM=50.605 Q 0
  1.  ;
  1.  ;Lab tests not allowed.
  1.  I FILENUM=60 Q 0
  1.  ;
  1.  ;Radiology procedures not allowed.
  1.  I FILENUM=71 Q 0
  1.  ;
  1.  ;ICD9 (used in Dialogs) not allowed.
  1.  I FILENUM=80 Q 0
  1.  ;
  1.  ;ICD0 not allowed.
  1.  I FILENUM=80.1 Q 0
  1.  ;
  1.  ;CPT (used in Dialogs) not allowed.
  1.  I FILENUM=81 Q 0
  1.  ;
  1.  ;Order Dialogs not allowed.
  1.  I FILENUM=101.41 Q 0
  1.  ;
  1.  ;Orderable Items not allowed.
  1.  I FILENUM=101.43 Q 0
  1.  ;
  1.  ;GMRV VITAL TYPE not allowed.
  1.  I FILENUM=120.51 Q 0
  1.  ;
  1.  ;Health Summary Type allowed in certain cases.
  1.  I FILENUM=142 Q 1
  1.  ;
  1.  ;Health Summary Components allowed in certain cases.
  1.  I FILENUM=142.1 Q 1
  1.  ;
  1.  ;Health Summary Object allowed in certain cases.
  1.  I FILENUM=142.5 Q 1
  1.  ;
  1.  ;Mental Health Instruments not allowed.
  1.  I FILENUM=601 Q 0
  1.  I FILENUM=601.71 Q 0
  1.  ;
  1.  ;WV Notification Purpose not allowed.
  1.  I FILENUM=790.404 Q 0
  1.  ;
  1.  ;IHS/MSC/MGH Restrict file entries that IHS cannot create
  1.  ;IHS -Sites cannot create entries in MEASURMENT FILE
  1.  I FILENUM=9999999.07 Q 0
  1.  ;
  1.  ;IHS- Sites cannot create entries in health factors file
  1.  I FILENUM=9999999.64 Q 0
  1.  ;
  1.  ;IHS-Sites cannot create entries in exam file
  1.  I FILENUM=9999999.15 Q 0
  1.  ;
  1.  ;IHS-Sites cannot create entries in the patient education file
  1.  I FILENUM=9999999.09 Q 0
  1.  ;
  1.  ;IHS-Sites cannot create entries in the ski test file
  1.  I FILENUM=9999999.28 Q 0
  1.  ;
  1.  ;IHS-Sites cannot create entries in the immunization file
  1.  I FILENUM=9999999.14 Q 0
  1.  ;
  1.  ;TIU Document Definition allowed in certain cases.
  1.  I FILENUM=8925.1 Q 1
  1.  ;
  1.  ;If control gets to here then it is an allowed file type.
  1.  Q 1
  1.  ;
  1.  ;==============================================
  1. GETFACT(PT01,ATTR,NEWPT01,NAMECHG,IEN) ;Get the action for a file.
  1.  N ACTION,CHOICES,CSUM,DIR,FILENUM,MSG,RESULT
  1.  N SAME,X,Y
  1.  ;See if this entry is already defined.
  1. CHK ;
  1.  S NEWPT01=""
  1.  S FILENUM=ATTR("FILE NUMBER")
  1.  I IEN="" S IEN=$$EXISTS^PXRMEXIU(FILENUM,PT01)
  1.  I IEN D
  1.  .;If the entry already exists compare the existing entry checksum
  1.  .;with the packed entry checksum.
  1.  .;IHS/MSC/MGH 1009 Removed change made a long time ago
  1.  . S CSUM=$$FILE^PXRMEXCS(ATTR("FILE NUMBER"),IEN)
  1.  . ;S SAME=$S(ATTR("CHECKSUM")=CSUM:1,FILENUM=811.2:1,1:0)
  1.  . S SAME=$S(ATTR("CHECKSUM")=CSUM:1,1:0)
  1.  . D FEIMSG(SAME,.ATTR)
  1.  . I SAME S ACTION="S"
  1.  . I 'SAME D
  1.  .. S CHOICES=$S(FILENUM=801.41:"CMOUQS",FILENUM=811.5:"CMOUQS",1:"COUQS")
  1.  .. S DIR("B")="O"
  1.  .. S ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR)
  1.  E  D
  1.  . W !!,ATTR("FILE NAME")," entry ",PT01," is NEW,"
  1.  . W !,"what do you want to do?"
  1.  . S CHOICES="CIQS"
  1.  . S DIR("B")="I"
  1.  . S ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR)
  1.  ;
  1.  I ACTION="Q" Q ACTION
  1.  I ACTION="C" D
  1.  . S NEWPT01=$$GETUNAME^PXRMEXIU(.ATTR)
  1.  .;Make sure the NEW .01 passes any input transforms.
  1.  . I NEWPT01="" S ACTION="S"
  1.  . E  D CHK^DIE(ATTR("FILE NUMBER"),.01,"",NEWPT01,.RESULT,"MSG")
  1.  I $G(RESULT)="^" D  G CHK
  1.  . D AWRITE^PXRMUTIL("MSG")
  1.  . K RESULT
  1.  ;
  1.  I ACTION="O" D
  1.  .;If the action is overwrite double check that is what the user
  1.  .;really wants to do.
  1.  . N DIROUT,DIRUT,DTOUT,DUOUT
  1.  . K DIR
  1.  . S DIR(0)="Y"_U_"A"
  1.  . S DIR("A")="Are you sure you want to overwrite"
  1.  . S DIR("B")="N"
  1.  . D ^DIR
  1.  . I $D(DIROUT)!$D(DIRUT) S Y=0
  1.  . I $D(DTOUT)!$D(DUOUT) S Y=0
  1.  . S ACTION=$S(Y:"O",1:"S")
  1.  ;
  1.  I ACTION="P" D
  1.  . N DIC,Y
  1.  . S DIC=ATTR("FILE NUMBER")
  1.  . S DIC(0)="AEMQ"
  1.  . D ^DIC
  1.  . I Y=-1 S ACTION="S"
  1.  . E  S NEWPT01=$P(Y,U,2)
  1.  ;
  1.  I NEWPT01'="" S NAMECHG(ATTR("FILE NUMBER"),PT01)=NEWPT01
  1.  Q ACTION
  1.  ;
  1.  ;==============================================
  1. IOKTI(IEN,FILENUM,ITEMINFO) ;Check if it is ok to install this item.
  1.  ;To be installable, items from 801.41 need to be marked as selectable.
  1.  I FILENUM=801.41 Q $P(ITEMINFO,U,7)
  1.  ;Do not allow national routines.
  1.  I (FILENUM=0),'$D(PXRMINCF),$E($P(ITEMINFO,U,1),1,4)="PXRM" Q 0
  1.  N FDASTART,FDAEND
  1.  S FDASTART=$P(ITEMINFO,U,2)
  1.  S FDAEND=$P(ITEMINFO,U,3)
  1.  ;If FDSTART=FDAEND then only the .01 was packed so it may not
  1.  ;be installable.
  1.  I FDASTART=FDAEND Q $$IOKTP(FILENUM)
  1.  ;Check computed findings, national ones cannot be installed.
  1.  I (FILENUM=811.4),'$D(PXRMINCF) Q $$CFOKTI^PXRMEXU0(IEN,FDASTART,FDAEND)
  1.  Q 1
  1.  ;
  1.  ;==============================================
  1. IOKTP(FILENUM,IEN) ;Check if it is ok to pack this item.
  1.  ;If the entire file is not transportable we are done
  1.  I '$$FOKTT(FILENUM) Q 0
  1.  N OK
  1.  S OK=1
  1.  ;Check files where only specific entries can be packed.
  1.  ;
  1.  ;Health Summary Object not allowed if the type is not allowed
  1.  I FILENUM=142.5 D  Q OK
  1.  . I '$D(IEN)!($G(IEN)="") S OK=0 Q
  1.  . N HSTIEN
  1.  . S HSTIEN=$P($G(^GMT(142.5,IEN,0)),U,3) I HSTIEN'>0 S OK=0 Q
  1.  . S OK=$$IOKTP(142,HSTIEN)
  1.  .;DBIA #5445
  1.  . Q:'+$L($T(EN^GMTSDESC))     ;IHS/MSC/MGH Patch 1005
  1.  . I OK=0 D EN^GMTSDESC(IEN,142.5,"HS OBJECT")
  1.  ;
  1.  ;Health Summary Type not allowed if it contains local components
  1.  ;or PROGRESS NOTE SELECTED component
  1.  I FILENUM=142 D  Q OK
  1.  . I +$G(IEN)=0 S OK=0 Q
  1.  . N IND,PGSIEN
  1.  . S PGSIEN=$O(^GMT(142.1,"B","PROGRESS NOTES SELECTED",""))
  1.  . S IND=0,OK=1
  1.  . ;Scan HS Type for components, do not pack if it contains local
  1.  . ;components or selected Progress Note Component.
  1.  . F  S IND=$O(^GMT(142,IEN,1,IND)) Q:('OK)!(IND="")  D
  1.  .. I $P($G(^GMT(142,IEN,1,IND,0)),U,2)>99999 S OK=0 Q
  1.  .. I $P($G(^GMT(142,IEN,1,IND,0)),U,2)=PGSIEN S OK=0 Q
  1.  .;DBIA #5445
  1.  . I OK=0 D EN^GMTSDESC(IEN,142,"HS TYPE")
  1.  ;
  1.  ;Health Summary Components not allowed. National components do not
  1.  ;need to be packed, they already exist.
  1.  I FILENUM=142.1 D  Q OK
  1.  .;Only use to pack new national components being released
  1.  .;with the patch.
  1.  . I '$G(PXRMIHSC) S OK=0
  1.  .;DBIA #5445
  1.  .;Create description of local HS Components
  1.  . I +$G(IEN)>99999 D EN^GMTSDESC(IEN,142.1,"HS COMP")
  1.  ;
  1.  ;TIU Document Definition, allowed only if it is a health summary object.
  1.  I FILENUM=8925.1 D  Q OK
  1.  . N ARY,HSOIEN
  1.  . I '$D(IEN)!($G(IEN)="") S OK=0 Q
  1.  .;DBIA #5447
  1.  . D OBJBYIEN^TIUCHECK(.ARY,IEN)
  1.  . ;
  1.  . ;If not TIU object and INST is set, assume this is called from a
  1.  . ;national patch installing TIU Title and Document Class.
  1.  . I ARY(IEN,.04)'="O",PXRMINST=1 S OK=1 Q
  1.  . ;
  1.  . ;Only allow TIU/HS Object to be installed.
  1.  . I $G(ARY(IEN,9))'["S X=$$TIU^GMTSOBJ(" S OK=0 Q
  1.  . S HSOIEN=+$P(ARY(IEN,9),",",2)
  1.  . I HSOIEN'>0 S OK=0 Q
  1.  . S OK=$$IOKTP(142.5,HSOIEN)
  1.  . I OK=0 D TIU^PXRMEXU5(IEN,.ARY,"TIU OBJECT")
  1.  ;
  1.  Q OK
  1.  ;
  1.  ;==============================================
  1. NTHLOC(IEN,SUB) ;Save information about non-transportable hospital locations.
  1.  N HLOC,IND,NL
  1.  S NL=1,^TMP($J,SUB,IEN,NL)="Location List: "_$P(^PXRMD(810.9,IEN,0),U,1)
  1.  S IND=0
  1.  F  S IND=+$O(^PXRMD(810.9,IEN,44,IND)) Q:IND=0  D
  1.  . S NL=NL+1
  1.  .;DBIA #10040
  1.  . S HLOC=^PXRMD(810.9,IEN,44,IND,0),HLOC=$P(^SC(HLOC,0),U,1)
  1.  . S ^TMP($J,SUB,IEN,NL)="  "_HLOC
  1.  Q
  1.  ;
  1.  ;==============================================
  1. SETATTR(ATTR,FILE,PT01) ;Set the file attributes for the file FILE.
  1.  N MSG
  1.  S ATTR("FILE NUMBER")=FILE
  1.  S ATTR("FILE NAME")=$$GET1^DID(FILE,"","","NAME","","MSG")
  1.  ;This call gets the field length.
  1.  D FIELD^DID(FILE,.01,"","FIELD LENGTH","ATTR","MSG")
  1.  S ATTR("MIN FIELD LENGTH")=3
  1.  S (ATTR("NAME"),ATTR("PT01"))=PT01
  1.  Q
  1.  ;