PXRMEXFI ;SLC/PKR/PJH - Exchange utilities for file entries. ;10/21/2019
;;2.0;CLINICAL REMINDERS;**6,12,18,24,26,47,45**;Feb 04, 2005;Build 566
;==============================================
DELALL(FILENUM,NAME) ;Delete all file entries named NAME.
N IEN,IND,LIST,MSG
D FIND^DIC(FILENUM,"","@","MU",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
. W "."
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.
;
;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
;
;VA Product not allowed.
I FILENUM=50.68 Q 0
;
;Lab tests not allowed.
I FILENUM=60 Q 0
;
;Radiology procedures not allowed.
I FILENUM=71 Q 0
;
;Imaging type not allowed.
;I FILENUM=79.2 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
;
;TIU Document Definition allowed in certain cases.
I FILENUM=8925.1 Q 1
;
;Immunizations not allowed.
I FILENUM=9999999.14 Q 0
;
;Imaging type
I FILENUM=79.2 Q 0
;
;Reminder Function Finding
I FILENUM=801.47 Q 0
;
;Make sure the file exists.
I $$ROOT^DILFD(FILENUM)="" Q 0
;
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
;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.
. S CSUM=$$FILE^PXRMEXCS(ATTR("FILE NUMBER"),IEN)
. 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
. 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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMEXFI 8274 printed Oct 16, 2024@17:45:47 Page 2
PXRMEXFI ;SLC/PKR/PJH - Exchange utilities for file entries. ;10/21/2019
+1 ;;2.0;CLINICAL REMINDERS;**6,12,18,24,26,47,45**;Feb 04, 2005;Build 566
+2 ;==============================================
DELALL(FILENUM,NAME) ;Delete all file entries named NAME.
+1 NEW IEN,IND,LIST,MSG
+2 DO FIND^DIC(FILENUM,"","@","MU",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 WRITE "."
End DoDot:1
+5 IF 'SAME
Begin DoDot:1
+6 SET TEXT(2)="but the packed component is different, what do you want to do?"
+7 DO FORMAT^PXRMTEXT(1,70,2,.TEXT,.NOUT,.TEXTO)
+8 FOR IND=1:1:NOUT
WRITE !,TEXTO(IND)
End DoDot:1
+9 QUIT
+10 ;
+11 ;==============================================
FOKTT(FILENUM) ;Check if it is ok to transport items from this file.
+1 ;
+2 ;Drugs not allowed.
+3 IF FILENUM=50
QUIT 0
+4 ;
+5 ;VA Generic not allowed.
+6 IF FILENUM=50.6
QUIT 0
+7 ;
+8 ;VA Drug Class not allowed.
+9 IF FILENUM=50.605
QUIT 0
+10 ;
+11 ;VA Product not allowed.
+12 IF FILENUM=50.68
QUIT 0
+13 ;
+14 ;Lab tests not allowed.
+15 IF FILENUM=60
QUIT 0
+16 ;
+17 ;Radiology procedures not allowed.
+18 IF FILENUM=71
QUIT 0
+19 ;
+20 ;Imaging type not allowed.
+21 ;I FILENUM=79.2 Q 0
+22 ;
+23 ;ICD9 (used in Dialogs) not allowed.
+24 IF FILENUM=80
QUIT 0
+25 ;
+26 ;ICD0 not allowed.
+27 IF FILENUM=80.1
QUIT 0
+28 ;
+29 ;CPT (used in Dialogs) not allowed.
+30 IF FILENUM=81
QUIT 0
+31 ;
+32 ;Order Dialogs not allowed.
+33 IF FILENUM=101.41
QUIT 0
+34 ;
+35 ;Orderable Items not allowed.
+36 IF FILENUM=101.43
QUIT 0
+37 ;
+38 ;GMRV VITAL TYPE not allowed.
+39 IF FILENUM=120.51
QUIT 0
+40 ;
+41 ;Health Summary Type allowed in certain cases.
+42 IF FILENUM=142
QUIT 1
+43 ;
+44 ;Health Summary Components allowed in certain cases.
+45 IF FILENUM=142.1
QUIT 1
+46 ;
+47 ;Health Summary Object allowed in certain cases.
+48 IF FILENUM=142.5
QUIT 1
+49 ;
+50 ;Mental Health Instruments not allowed.
+51 IF FILENUM=601
QUIT 0
+52 IF FILENUM=601.71
QUIT 0
+53 ;
+54 ;WV Notification Purpose not allowed.
+55 IF FILENUM=790.404
QUIT 0
+56 ;
+57 ;TIU Document Definition allowed in certain cases.
+58 IF FILENUM=8925.1
QUIT 1
+59 ;
+60 ;Immunizations not allowed.
+61 IF FILENUM=9999999.14
QUIT 0
+62 ;
+63 ;Imaging type
+64 IF FILENUM=79.2
QUIT 0
+65 ;
+66 ;Reminder Function Finding
+67 IF FILENUM=801.47
QUIT 0
+68 ;
+69 ;Make sure the file exists.
+70 IF $$ROOT^DILFD(FILENUM)=""
QUIT 0
+71 ;
+72 IF $GET(PXRMIGDS)
QUIT 1
+73 ;If a file has been standardized do not transport it.
+74 ;DBIA #4640
+75 IF $PIECE($$GETSTAT^HDISVF01(FILENUM),U,1)>0
QUIT 0
+76 ;If control gets to here then it is an allowed file type.
+77 ;
+78 QUIT 1
+79 ;
+80 ;==============================================
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 SET CSUM=$$FILE^PXRMEXCS(ATTR("FILE NUMBER"),IEN)
+8 SET SAME=$SELECT(ATTR("CHECKSUM")=CSUM:1,1:0)
+9 DO FEIMSG(SAME,.ATTR)
+10 IF SAME
SET ACTION="S"
+11 IF 'SAME
Begin DoDot:2
+12 SET CHOICES=$SELECT(FILENUM=801.41:"CMOUQS",FILENUM=811.5:"CMOUQS",1:"COUQS")
+13 SET DIR("B")="O"
+14 SET ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR)
End DoDot:2
End DoDot:1
+15 IF '$TEST
Begin DoDot:1
+16 WRITE !!,ATTR("FILE NAME")," entry ",PT01," is NEW,"
+17 WRITE !,"what do you want to do?"
+18 SET CHOICES="CIQS"
+19 SET DIR("B")="I"
+20 SET ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR)
End DoDot:1
+21 ;
+22 IF ACTION="Q"
QUIT ACTION
+23 IF ACTION="C"
Begin DoDot:1
+24 SET NEWPT01=$$GETUNAME^PXRMEXIU(.ATTR)
+25 ;Make sure the NEW .01 passes any input transforms.
+26 IF NEWPT01=""
SET ACTION="S"
+27 IF '$TEST
DO CHK^DIE(ATTR("FILE NUMBER"),.01,"",NEWPT01,.RESULT,"MSG")
End DoDot:1
+28 IF $GET(RESULT)="^"
Begin DoDot:1
+29 DO AWRITE^PXRMUTIL("MSG")
+30 KILL RESULT
End DoDot:1
GOTO CHK
+31 ;
+32 IF ACTION="O"
Begin DoDot:1
+33 ;If the action is overwrite double check that is what the user
+34 ;really wants to do.
+35 NEW DIROUT,DIRUT,DTOUT,DUOUT
+36 KILL DIR
+37 SET DIR(0)="Y"_U_"A"
+38 SET DIR("A")="Are you sure you want to overwrite"
+39 SET DIR("B")="N"
+40 DO ^DIR
+41 IF $DATA(DIROUT)!$DATA(DIRUT)
SET Y=0
+42 IF $DATA(DTOUT)!$DATA(DUOUT)
SET Y=0
+43 SET ACTION=$SELECT(Y:"O",1:"S")
End DoDot:1
+44 ;
+45 IF ACTION="P"
Begin DoDot:1
+46 NEW DIC,Y
+47 SET DIC=ATTR("FILE NUMBER")
+48 SET DIC(0)="AEMQ"
+49 DO ^DIC
+50 IF Y=-1
SET ACTION="S"
+51 IF '$TEST
SET NEWPT01=$PIECE(Y,U,2)
End DoDot:1
+52 ;
+53 IF NEWPT01'=""
SET NAMECHG(ATTR("FILE NUMBER"),PT01)=NEWPT01
+54 QUIT ACTION
+55 ;
+56 ;==============================================
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 IF OK=0
DO EN^GMTSDESC(IEN,142.5,"HS OBJECT")
End DoDot:1
QUIT OK
+15 ;
+16 ;Health Summary Type not allowed if it contains local components
+17 ;or PROGRESS NOTE SELECTED component
+18 IF FILENUM=142
Begin DoDot:1
+19 IF +$GET(IEN)=0
SET OK=0
QUIT
+20 NEW IND,PGSIEN
+21 SET PGSIEN=$ORDER(^GMT(142.1,"B","PROGRESS NOTES SELECTED",""))
+22 SET IND=0
SET OK=1
+23 ;Scan HS Type for components, do not pack if it contains local
+24 ;components or selected Progress Note Component.
+25 FOR
SET IND=$ORDER(^GMT(142,IEN,1,IND))
if ('OK)!(IND="")
QUIT
Begin DoDot:2
+26 IF $PIECE($GET(^GMT(142,IEN,1,IND,0)),U,2)>99999
SET OK=0
QUIT
+27 IF $PIECE($GET(^GMT(142,IEN,1,IND,0)),U,2)=PGSIEN
SET OK=0
QUIT
End DoDot:2
+28 ;DBIA #5445
+29 IF OK=0
DO EN^GMTSDESC(IEN,142,"HS TYPE")
End DoDot:1
QUIT OK
+30 ;
+31 ;Health Summary Components not allowed. National components do not
+32 ;need to be packed, they already exist.
+33 IF FILENUM=142.1
Begin DoDot:1
+34 ;Only use to pack new national components being released
+35 ;with the patch.
+36 IF '$GET(PXRMIHSC)
SET OK=0
+37 ;DBIA #5445
+38 ;Create description of local HS Components
+39 IF +$GET(IEN)>99999
DO EN^GMTSDESC(IEN,142.1,"HS COMP")
End DoDot:1
QUIT OK
+40 ;
+41 ;TIU Document Definition, allowed only if it is a health summary object.
+42 IF FILENUM=8925.1
Begin DoDot:1
+43 NEW ARY,HSOIEN
+44 IF '$DATA(IEN)!($GET(IEN)="")
SET OK=0
QUIT
+45 ;DBIA #5447
+46 DO OBJBYIEN^TIUCHECK(.ARY,IEN)
+47 ;
+48 ;If not TIU object and INST is set, assume this is called from a
+49 ;national patch installing TIU Title and Document Class.
+50 IF ARY(IEN,.04)'="O"
IF PXRMINST=1
SET OK=1
QUIT
+51 ;
+52 ;Only allow TIU/HS Object to be installed.
+53 IF $GET(ARY(IEN,9))'["S X=$$TIU^GMTSOBJ("
SET OK=0
QUIT
+54 SET HSOIEN=+$PIECE(ARY(IEN,9),",",2)
+55 IF HSOIEN'>0
SET OK=0
QUIT
+56 SET OK=$$IOKTP(142.5,HSOIEN)
+57 IF OK=0
DO TIU^PXRMEXU5(IEN,.ARY,"TIU OBJECT")
End DoDot:1
QUIT OK
+58 ;
+59 QUIT OK
+60 ;
+61 ;==============================================
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 ;
