- 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 Jan 18, 2025@02:46:09 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 ;