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