PXRMEXPD ;SLC/PKR - General packing driver. ;08/02/2013
;;2.0;CLINICAL REMINDERS;**12,17,16,18,22,26**;Feb 04, 2005;Build 404
;==========================
BLDDESC(USELLIST,TMPIND) ;If multiple entries have been selected
;then initialize the description with the selected list.
N IEN,NL,NOUT,TEXT,TEXTOUT
S TEXT(1)="The following Clinical Reminder items were selected for packing:\\"
S FILENUM=0,NL=1
F S FILENUM=$O(USELLIST(FILENUM)) Q:FILENUM="" D
. I NL>1 S NL=NL+1,TEXT(NL)="\\"
. S NL=NL+1,TEXT(NL)=$$GET1^DID(FILENUM,"","","NAME")_"\\"
. S IEN=0
. F S IEN=+$O(USELLIST(FILENUM,"IEN",IEN)) Q:IEN=0 D
.. S NL=NL+1,TEXT(NL)=" "_$$GET1^DIQ(FILENUM,IEN,".01")_"\\"
D FORMAT^PXRMTEXT(1,70,NL,.TEXT,.NOUT,.TEXTOUT)
K ^TMP(TMPIND,$J,"DESC")
F IND=1:1:NOUT S ^TMP(TMPIND,$J,"DESC",1,IND,0)=TEXTOUT(IND)
Q
;
;==========================
BLDTEXT(TMPIND) ;Combine the source information and the user's input into the
;"TEXT" array.
N IC,IND
S (IC,IND)=0
F S IC=$O(^TMP(TMPIND,$J,"SRC",IC)) Q:+IC=0 D
. S IND=IND+1
. S ^TMP(TMPIND,$J,"TEXT",1,IND)=^TMP(TMPIND,$J,"SRC",IC)
;
S IC=0
F S IC=$O(^TMP(TMPIND,$J,"TXT",1,IC)) Q:+IC=0 D
. S IND=IND+1
. S ^TMP(TMPIND,$J,"TEXT",1,IND)=^TMP(TMPIND,$J,"TXT",1,IC,0)
Q
;
;==========================
CLDIQOUT(FILENUM,IEN,FIELD,IENROOT,DIQOUT) ;Clean-up the DIQOUT returned by
;the GETS^DIQ call.
N NOSTUB
S NOSTUB=0
I (FILENUM=811.4),($P(^PXRMD(811.4,IEN,100),U,1)="N") S NOSTUB=1
;Remove edit history from all reminder files.
D RMEH^PXRMEXPU(FILENUM,.DIQOUT,NOSTUB)
;Convert the iens to the FDA adding form.
D CONTOFDA^PXRMEXPU(.DIQOUT,.IENROOT)
;Remove hospital locations from location lists
I FILENUM=810.9 K DIQOUT(810.944)
;Don't transport the obsolete taxonomy fields.
I FILENUM=811.2 K DIQOUT(811.22102),DIQOUT(811.22103),DIQOUT(811.22104),DIQOUT(811.23102),DIQOUT(811.23104)
;TIU conversion for TIU/HS objects
I FILENUM=8925.1,FIELD="**" D TIUCONV(FILENUM,IEN,.DIQOUT)
Q
;
;==========================
CMPLIST(CMPLIST,SELLIST,FILELST,ERROR) ;Process the selected list and build a
;complete list of components to be packed.
N CIEN,IND,JND,FNUM,LRD,NUM,PACKLIST,ROUTINE
S ERROR=0
F IND=1:1:FILELST(0) D
. S FNUM=$P(FILELST(IND),U,1)
. I '$D(SELLIST(FNUM)) Q
. S ROUTINE=$$GETSRTN^PXRMEXPS(FNUM)_"(FNUM,CIEN,.PACKLIST)"
. S NUM=0
. F S NUM=+$O(SELLIST(FNUM,NUM)) Q:NUM=0 S CIEN=SELLIST(FNUM,NUM) D @ROUTINE
;PACKLIST is built by following all pointers. Reversing the order
;for the Exchange install should allow resolution of pointers.
S FNUM=""
F S FNUM=$O(PACKLIST(FNUM)) Q:FNUM="" D
. I $D(PACKLIST(FNUM,"ERROR")) D
.. S IND=0,ERROR=ERROR+1
.. I ERROR=1 W !
.. F S IND=+$O(PACKLIST(FNUM,"ERROR",IND)) Q:IND=0 W !,PACKLIST(FNUM,"ERROR",IND)," IEN=",IND
. S IND="IEN",JND=0
. F S IND=+$O(PACKLIST(FNUM,IND),-1) Q:IND=0 S JND=JND+1,CMPLIST(FNUM,JND)=PACKLIST(FNUM,IND)
;If any definitions have a linked dialog add the linked dialog to the
;selection list so it can be marked as selected.
I '$D(CMPLIST(811.9)) Q
S NUM=$O(SELLIST(801.41,"IEN"),-1)
S IND=0
F S IND=$O(CMPLIST(811.9,IND)) Q:IND="" D
. S LRD=$G(^PXD(811.9,CMPLIST(811.9,IND),51))
. I LRD'="" S NUM=NUM+1,SELLIST(801.41,NUM)=LRD,SELLIST(801.41,"IEN",LRD)=NUM
I ERROR D
. W !,"Cannot create the packed file due to the above error(s)."
. H 2
Q
;
;==========================
CRE ;Pack a reminder component and store it in the repository.
N CMPLIST,CNT,DIEN,DERRFND,DERRMSG,EFNAME,ERROR,FAIL,FAILTYPE,FILELST
N OUTPUT,POA,RANK,SERROR,SELLIST,SUCCESS,TMPIND,USELLIST
S TMPIND="PXRMEXPR"
K ^TMP(TMPIND,$J)
S FILELST(1)=811.4_U_$$GET1^DID(811.4,"","","NAME")
S FILELST(2)=810.8_U_$$GET1^DID(810.8,"","","NAME")
S FILELST(3)=811.9_U_$$GET1^DID(811.9,"","","NAME")
S FILELST(4)=801.41_U_$$GET1^DID(801.41,"","","NAME")
S FILELST(5)=810.7_U_$$GET1^DID(810.7,"","","NAME")
S FILELST(6)=810.2_U_$$GET1^DID(810.2,"","","NAME")
S FILELST(7)=810.4_U_$$GET1^DID(810.4,"","","NAME")
S FILELST(8)=810.9_U_$$GET1^DID(810.9,"","","NAME")
S FILELST(9)=811.6_U_$$GET1^DID(811.6,"","","NAME")
S FILELST(10)=811.2_U_$$GET1^DID(811.2,"","","NAME")
S FILELST(11)=811.5_U_$$GET1^DID(811.5,"","","NAME")
S FILELST(12)=801_U_$$GET1^DID(801,"","","NAME")
S FILELST(13)=801.1_U_$$GET1^DID(801.1,"","","NAME")
S FILELST(0)=13
D PACKORD(.RANK)
;
;Get the list to pack.
D FSEL(.SELLIST,.FILELST)
;
K VALMHDR
I '$D(SELLIST) S VALMHDR(1)="No reminder items were selected!" Q
;Save the user's selections.
M USELLIST=SELLIST
;Process the selected list to build a complete list of components
;to be packed.
D CMPLIST(.CMPLIST,.SELLIST,.FILELST,.ERROR)
I ERROR K ^TMP(TMPIND,$J) Q
;
;Check reminder dialogs for errors
N FAILTYPE
S FAIL=0
I $D(SELLIST(801.41)) D I FAIL="F" K ^TMP(TMPIND,$J) Q
.W !,"Checking reminder dialog(s) for errors."
. S DIEN=0
.;Check individual reminder dialogs
. F S DIEN=$O(SELLIST(801.41,"IEN",DIEN)) Q:DIEN'>0 D
.. I FAIL=0 W "."
.. S FAILTYPE=$$RETARR^PXRMDLRP(DIEN,.OUTPUT) Q:'$D(OUTPUT)
.. I FAILTYPE="F" S FAIL="F"
.. I FAILTYPE="W",FAIL=0 S FAIL="W"
.. W !!,$S(FAILTYPE="W":"**WARNING**",1:"**FATAL ERROR**")
.. S CNT=0 F S CNT=$O(OUTPUT(CNT)) Q:CNT'>0 W !,OUTPUT(CNT)
.. K OUTPUT
.;
. I FAIL="W" H 2
. I FAIL=0 W !,"No problems found." H 1 Q
. I FAIL="F" W !!,"Cannot create the packed file. Please correct the above fatal error(s)." H 2
;
;Create the header information.
D HEADER(TMPIND,.USELLIST,.SELLIST,.RANK,.EFNAME)
I EFNAME=-1 Q
;
;Order the component list.
D ORDER(.CMPLIST,.RANK,.POA)
;Pack the list
D PACK(.CMPLIST,.POA,TMPIND,.SELLIST,.SERROR)
I SERROR K ^TMP(TMPIND,$J) Q
;Add information to the description about quick orders, TIU health
;summary objects, and health summaries that are included but are
;not exchangeable.
D NEXINFO(TMPIND)
D STOREPR^PXRMEXU2(.SUCCESS,EFNAME,TMPIND,.SELLIST)
K ^TMP(TMPIND,$J)
I SUCCESS D
. S VALMHDR(1)=EFNAME_" was saved in the Exchange File."
. D BLDLIST^PXRMEXLC(1)
E D
. S VALMHDR(1)="Creation of Exchange File entry "_EFNAME
. S VALMHDR(2)="failed; it was not saved!"
Q
;
;==========================
FSEL(LIST,FILELST) ;Select file list.
N ALIST,DIR,DIROUT,DIRUT,DONE,DTOUT,DUOUT,IND,X,Y
F IND=1:1:FILELST(0) S ALIST(IND)=$$RJ^XLFSTR(IND,4," ")_" "_$P(FILELST(IND),U,2)
M DIR("A")=ALIST
S DIR("A")="Select a file"
S DIR(0)="NO^1:"_FILELST(0)
S DONE=0
F Q:DONE D
. W !!,"Select from the following reminder files:"
. D ^DIR
. I (Y="")!(Y["^") S DONE=1 Q
. I $D(DIROUT)!$D(DIRUT) S DONE=1 Q
. I $D(DUOUT)!$D(DTOUT) S DONE=1 Q
. D IENSEL(.LIST,Y,.FILELST)
Q
;
;==========================
IENSEL(LIST,ID,FILELST) ;Select entries from the selected file.
N DIC,DIR,DIROUT,DIRUT,DONE,DTOUT,DUOUT,FILENUM,NUMF,X,Y
S (DIC,FILENUM)=$P(FILELST(ID),U,1)
S NUMF=+$O(LIST(FILENUM,""),-1)
S DIC(0)="QEA"
S DONE=0
F Q:DONE D
. D ^DIC
. I Y=-1 S DONE=1 Q
. I $D(DIROUT)!$D(DIRUT) S DONE=1 Q
. I $D(DUOUT)!$D(DTOUT) S DONE=1 Q
. S NUMF=NUMF+1
. S LIST(FILENUM,NUMF)=+Y
. S LIST(FILENUM,"IEN",+Y)=NUMF
. W !,"Enter another one or just press enter to go back to file selection."
Q
;
;==========================
GETTEXT(FILENUM,IEN,TMPIND,INDEX) ;Let the user input some text.
N DIC,DWLW,DWPK,FIELDNUM,TYPE
;If this is the description text, (signfied by FILENUM>0) load the
;description or short description as the default.
I FILENUM>0 D
. S FIELDNUM=$$FLDNUM^DILFD(FILENUM,"DESCRIPTION"),TYPE="WP"
. I FIELDNUM=0 S FIELDNUM=$$FLDNUM^DILFD(FILENUM,"SHORT DESCRIPTION"),TYPE="SD"
E S FIELDNUM=0
I FIELDNUM>0 D
. N MSG,WP,X
. I TYPE="WP" D
.. S X=$$GET1^DIQ(FILENUM,IEN,FIELDNUM,"Z","WP","MSG")
.. M ^TMP(TMPIND,$J,INDEX,1)=WP
. I TYPE="SD" D
.. S X=$$GET1^DIQ(FILENUM,IEN,FIELDNUM,"","","MSG")
.. S ^TMP(TMPIND,$J,INDEX,1,1,0)=X
S DIC="^TMP(TMPIND,$J,"""_INDEX_""",1,"
S DWLW=72,DWPK=1
D EN^DIWE
Q
;
;==========================
GDIQF(FILENUM,FILENAME,IEN,IND,TMPIND,SELLIST,SERROR) ;Save file entries into
;^TMP(TMPIND,$J).
N CSUM,DIQOUT,IENROOT,FIELD,MSG,NUM
K DIQOUT,IENROOT
;If the file entry is ok to install then get the entire entry,
;otherwise just get the .01.
S FIELD=$S($$IOKTP^PXRMEXFI(FILENUM,IEN):"**",1:.01)
;
;Items from file 142, 142.5, and 8925.1 need to be added to the
;SELLIST array if $$IOKTP returns "**". These items are IEN specific
;and the check needs to be done at time of packing this is why they
;are added to SELLIST.
I ((FILENUM=142)!(FILENUM=142.5)!(FILENUM=8925.1))&(FIELD="**") D
.S NUM=$O(SELLIST(FILENUM,"IEN",""),-1)
.S NUM=NUM+1,SELLIST(FILENUM,"IEN",IEN)=NUM,SELLIST(FILENUM,NUM)=IEN
;
D GETS^DIQ(FILENUM,IEN,FIELD,"N","DIQOUT","MSG")
I $D(MSG) D Q
. S SERROR=1
. N ETEXT
. S ETEXT="GETS^DIQ failed for "_FILENAME_", ien="_IEN_";"
. W !,ETEXT
. W !,"it returned the following error:"
. D AWRITE^PXRMUTIL("MSG")
. H 2
. K MSG
D CLDIQOUT(FILENUM,IEN,FIELD,.IENROOT,.DIQOUT)
S ^TMP("PXRMEXCS",$J,IND,FILENAME)=$$DIQOUTCS^PXRMEXCS(.DIQOUT)
;Load the converted DIQOUT into TMP.
M ^TMP(TMPIND,$J,IND,FILENAME)=DIQOUT
M ^TMP(TMPIND,$J,IND,FILENAME_"_IENROOT")=IENROOT
Q
;
;==========================
GRTN(ROUTINE,TMPIND,SERROR) ;Save routines into ^TMP(TMPIND,$J).
N DIF,IEN,IND,RA,TEMP,X,XCNP
S X=ROUTINE
X ^%ZOSF("TEST")
I $T D
. K RA
. S DIF="RA("
. S XCNP=0
. X ^%ZOSF("LOAD")
. S ^TMP("PXRMEXCS",$J,"ROUTINE",X)=$$ROUTINE^PXRMEXCS(.RA)
. M ^TMP(TMPIND,$J,"ROUTINE",X)=RA
E D
. S SERROR=1
. W !,"Warning could not find routine ",X
. H 2
Q
;
;==========================
;information.
N DIR,EXTYPE,IEN,IND,FILENAME,FILENUM,NFNUM,NIEN,PNAME,Y
S (FILENAME,FILENUM,IEN,NIEN)="",NFNUM=0
F S FILENUM=$O(USELLIST(FILENUM)) Q:FILENUM="" S NFNUM=NFNUM+1
I NFNUM=1 D
. S FILENUM=$O(USELLIST(""))
. S IND="",NIEN=0
. F S IND=$O(USELLIST(FILENUM,IND)) Q:IND="IEN" S NIEN=NIEN+1
. I NIEN=1 D
.. S IND=$O(USELLIST(FILENUM,""))
.. S IEN=USELLIST(FILENUM,IND)
.. S NAME=$$GET1^DIQ(FILENUM,IEN,.01)
.. S FILENAME=$$GET1^DID(FILENUM,"","","NAME")
..;If only one item was selected make it the default.
.. S DIR("B")=NAME
;Get the Exchange file entry name.
S DIR(0)="FAU^3:64"
S DIR("A")="Enter the Exchange File entry name: "
D ^DIR
I (Y="")!($D(DTOUT))!($D(DUOUT)) S EFNAME=-1 Q
S EFNAME=Y
K DIR
;Save the source information.
D PUTSRC(FILENAME,EFNAME,TMPIND)
S PNAME=$S(NIEN=1:FILENAME,1:"Exchange File entry")
;If multiple items were selected for packing initialize the
;description with the selection list.
I (NFNUM>1)!(NIEN>1) D BLDDESC(.USELLIST,TMPIND)
;If a single item was selected the description will be initialized
;with the selected item's description. In either case the user can
;input additional description text.
W !,"Enter a description of the ",PNAME," you are packing." H 2
D GETTEXT(FILENUM,IEN,TMPIND,"DESC")
;
;Have the user input keywords for indexing the entry.
W !,"Enter keywords or phrases to help index the entry you are packing."
W !,"Separate the keywords or phrases on each line with commas." H 2
D GETTEXT(0,0,TMPIND,"KEYWORD")
;
;Combine the source and input text into the "TEXT" array.
D BLDTEXT(TMPIND)
Q
;
;==========================
NEXINFO(TMPIND) ;Add information to the description about quick orders,
;TIU health summary objects, and health summaries that are included
;but are not exchangeable.
N NL,NLS
S (NL,NLS)=$P($G(^TMP(TMPIND,$J,"DESC",1,0)),U,4)
I $D(^TMP($J,"ORDER DIALOG")) D
. I NL>NLS S NL=NL+1,^TMP(TMPIND,$J,"DESC",1,NL,0)=""
. S NL=NL+1,^TMP(TMPIND,$J,"DESC",1,NL,0)="Non-exchangeable order dialog(s):"
. D NEXINFOA(TMPIND,"ORDER DIALOG",.NL)
I $D(^TMP($J,"TIU OBJECT")) D
. I NL>NLS S NL=NL+1,^TMP(TMPIND,$J,"DESC",1,NL,0)=""
. S NL=NL+1,^TMP(TMPIND,$J,"DESC",1,NL,0)="Non-exchangeable TIU object(s):"
. D NEXINFOA(TMPIND,"TIU OBJECT",.NL)
I $D(^TMP($J,"HS OBJECT")) D
. I NL>NLS S NL=NL+1,^TMP(TMPIND,$J,"DESC",1,NL,0)=""
. S NL=NL+1,^TMP(TMPIND,$J,"DESC",1,NL,0)="Non-exchangeable health summary object(s):"
. D NEXINFOA(TMPIND,"HS OBJECT",.NL)
I $D(^TMP($J,"HS TYPE")) D
. I NL>NLS S NL=NL+1,^TMP(TMPIND,$J,"DESC",1,NL,0)=""
. S NL=NL+1,^TMP(TMPIND,$J,"DESC",1,NL,0)="Non-exchangeable health summary type(s):"
. D NEXINFOA(TMPIND,"HS TYPE",.NL)
I $D(^TMP($J,"HS COMP")) D
. I NL>NLS S NL=NL+1,^TMP(TMPIND,$J,"DESC",1,NL,0)=""
. S NL=NL+1,^TMP(TMPIND,$J,"DESC",1,NL,0)="Non-exchangeable health summary component(s):"
. D NEXINFOA(TMPIND,"HS COMP",.NL)
I $D(^TMP($J,"LOCATION LIST")) D
. I NL>NLS S NL=NL+1,^TMP(TMPIND,$J,"DESC",1,NL,0)=""
. S NL=NL+1,^TMP(TMPIND,$J,"DESC",1,NL,0)="Non-exchangeable location list hospital locations:"
. D NEXINFOA(TMPIND,"LOCATION LIST",.NL)
I NL>NLS S $P(^TMP(TMPIND,$J,"DESC",1,0),U,3,4)=NL_U_NL
Q
;
;==========================
NEXINFOA(TMPIND,SUB,NL) ;
N IEN,LNUM
I SUB'["ORDER" S NL=NL+1,^TMP(TMPIND,$J,"DESC",1,NL,0)=$$REPEAT^XLFSTR("-",79)
S IEN=0
F S IEN=$O(^TMP($J,SUB,IEN)) Q:IEN'>0 D
.S LNUM=0
.F S LNUM=$O(^TMP($J,SUB,IEN,LNUM)) Q:LNUM="" D
..S NL=NL+1,^TMP(TMPIND,$J,"DESC",1,NL,0)=^TMP($J,SUB,IEN,LNUM)
I SUB'["ORDER" S NL=NL+1,^TMP(TMPIND,$J,"DESC",1,NL,0)=$$REPEAT^XLFSTR("-",79)
K ^TMP($J,SUB)
Q
;
;==========================
ORDER(CMPLIST,RANK,POA) ;Order the component list so pointers can be resolved.
N FILENUM,ORDER,PORDER
S FILENUM="",ORDER=0
F S FILENUM=$O(CMPLIST(FILENUM)) Q:FILENUM="" D
. S PORDER=$G(RANK("FN",FILENUM))
. I PORDER="" S ORDER=ORDER+1,PORDER=ORDER
. S POA(PORDER)=FILENUM
Q
;
;==========================
PACK(CMPLIST,POA,TMPIND,SELLIST,SERROR) ;Create the packed entry, store it in
;^TMP(TMPIND,$J). TMPIND should be namespaced and set by the caller.
N IEN,IND,JND,KND,FILENAME,FILENUM,ROUTINE
W !,"Packing components ..."
S (KND,SERROR)=0
S IND=""
F S IND=$O(POA(IND)) Q:IND="" D
. S FILENUM=POA(IND)
. S FILENAME=$S(FILENUM=0:"ROUTINE",1:$$GET1^DID(FILENUM,"","","NAME"))
. S JND=""
. F S JND=$O(CMPLIST(FILENUM,JND)) Q:JND="" D
.. S IEN=CMPLIST(FILENUM,JND)
.. I FILENUM=0 W !,"Adding routine ",IEN
.. E W !,"Adding ",FILENAME," ",$$GET1^DIQ(FILENUM,IEN,.01),", IEN=",IEN
.. I FILENUM=0 D GRTN(IEN,TMPIND,.SERROR)
.. I FILENUM>0 S KND=KND+1 D GDIQF(FILENUM,FILENAME,IEN,KND,TMPIND,.SELLIST,.SERROR)
;
S ^TMP(TMPIND,$J,"NUMF")=KND
W !,"Packing is complete."
;If there were any errors saving the data kill the ^TMP array.
I SERROR K ^TMP(TMPIND,$J)
Q
;
;==========================
PACKORD(RANK) ;
S RANK("FN",801.41)=7000,RANK(7000)=801.41
S RANK("FN",810.2)=11000,RANK(11000)=810.2
S RANK("FN",810.4)=8000,RANK(8000)=810.4
S RANK("FN",810.7)=10000,RANK(10000)=810.7
S RANK("FN",810.8)=9000,RANK(9000)=810.8
S RANK("FN",810.9)=4000,RANK(4000)=810.9
S RANK("FN",811.2)=3000,RANK(3000)=811.2
S RANK("FN",811.4)=2000,RANK(2000)=811.4
S RANK("FN",811.5)=5000,RANK(5000)=811.5
S RANK("FN",811.6)=1000,RANK(1000)=811.6
S RANK("FN",811.9)=6000,RANK(6000)=811.9
S RANK("FN",142.1)=100000,RANK(100000)=142.1
S RANK("FN",142)=100100,RANK(100100)=142
S RANK("FN",142.5)=100200,RANK(100200)=142.5
S RANK("FN",8925.1)=100300,RANK(100300)=8925.1
S RANK("FN",801)=100500,RANK(100500)=801
S RANK("FN",801.1)=100400,RANK(100400)=801.1
Q
;
;==========================
PUTSRC(FILENAME,NAME,TMPIND) ;Save the source information.
N LOC
S LOC=$$SITE^VASITE
I FILENAME'="" S ^TMP(TMPIND,$J,"SRC","FILENAME")=FILENAME
S ^TMP(TMPIND,$J,"SRC","NAME")=NAME
S ^TMP(TMPIND,$J,"SRC","USER")=$$GET1^DIQ(200,DUZ,.01)
S ^TMP(TMPIND,$J,"SRC","SITE")=$P(LOC,U,2)
S ^TMP(TMPIND,$J,"SRC","DATE")=$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
Q
;
;==========================
TIUCONV(FILENUM,IEN,ARRAY) ;Convert health summary object to external.
N HSO,IENS,NAME
S IENS="+"_IEN_","
;Allows non-objects to be packed up
I ARRAY(FILENUM,IENS,.04)'="OBJECT" Q
;
I $G(ARRAY(FILENUM,IENS,9))'["$$TIU^GMTSOBJ" D Q
. S ARRAY(FILENUM,IENS,9)="NOT A HS OBJECT"
S HSO=$P(ARRAY(FILENUM,IENS,9),",",2)
S HSO=$P(HSO,")")
;Handle corrupted health summary object names.
I +HSO>0 S NAME=$P($G(^GMT(142.5,HSO,0)),U,1)
E S NAME="MISSING"
S ARRAY(FILENUM,IENS,9)="S X=$$TIU^GMTSOBJ(DFN,"_NAME_")"
S ARRAY(FILENUM,IENS,99)=""
Q
;
PXRMEXPD ;SLC/PKR - General packing driver. ;08/02/2013
+1 ;;2.0;CLINICAL REMINDERS;**12,17,16,18,22,26**;Feb 04, 2005;Build 404
+2 ;==========================
BLDDESC(USELLIST,TMPIND) ;If multiple entries have been selected
+1 ;then initialize the description with the selected list.
+2 NEW IEN,NL,NOUT,TEXT,TEXTOUT
+3 SET TEXT(1)="The following Clinical Reminder items were selected for packing:\\"
+4 SET FILENUM=0
SET NL=1
+5 FOR
SET FILENUM=$ORDER(USELLIST(FILENUM))
IF FILENUM=""
QUIT
Begin DoDot:1
+6 IF NL>1
SET NL=NL+1
SET TEXT(NL)="\\"
+7 SET NL=NL+1
SET TEXT(NL)=$$GET1^DID(FILENUM,"","","NAME")_"\\"
+8 SET IEN=0
+9 FOR
SET IEN=+$ORDER(USELLIST(FILENUM,"IEN",IEN))
IF IEN=0
QUIT
Begin DoDot:2
+10 SET NL=NL+1
SET TEXT(NL)=" "_$$GET1^DIQ(FILENUM,IEN,".01")_"\\"
End DoDot:2
End DoDot:1
+11 DO FORMAT^PXRMTEXT(1,70,NL,.TEXT,.NOUT,.TEXTOUT)
+12 KILL ^TMP(TMPIND,$JOB,"DESC")
+13 FOR IND=1:1:NOUT
SET ^TMP(TMPIND,$JOB,"DESC",1,IND,0)=TEXTOUT(IND)
+14 QUIT
+15 ;
+16 ;==========================
BLDTEXT(TMPIND) ;Combine the source information and the user's input into the
+1 ;"TEXT" array.
+2 NEW IC,IND
+3 SET (IC,IND)=0
+4 FOR
SET IC=$ORDER(^TMP(TMPIND,$JOB,"SRC",IC))
IF +IC=0
QUIT
Begin DoDot:1
+5 SET IND=IND+1
+6 SET ^TMP(TMPIND,$JOB,"TEXT",1,IND)=^TMP(TMPIND,$JOB,"SRC",IC)
End DoDot:1
+7 ;
+8 SET IC=0
+9 FOR
SET IC=$ORDER(^TMP(TMPIND,$JOB,"TXT",1,IC))
IF +IC=0
QUIT
Begin DoDot:1
+10 SET IND=IND+1
+11 SET ^TMP(TMPIND,$JOB,"TEXT",1,IND)=^TMP(TMPIND,$JOB,"TXT",1,IC,0)
End DoDot:1
+12 QUIT
+13 ;
+14 ;==========================
CLDIQOUT(FILENUM,IEN,FIELD,IENROOT,DIQOUT) ;Clean-up the DIQOUT returned by
+1 ;the GETS^DIQ call.
+2 NEW NOSTUB
+3 SET NOSTUB=0
+4 IF (FILENUM=811.4)
IF ($PIECE(^PXRMD(811.4,IEN,100),U,1)="N")
SET NOSTUB=1
+5 ;Remove edit history from all reminder files.
+6 DO RMEH^PXRMEXPU(FILENUM,.DIQOUT,NOSTUB)
+7 ;Convert the iens to the FDA adding form.
+8 DO CONTOFDA^PXRMEXPU(.DIQOUT,.IENROOT)
+9 ;Remove hospital locations from location lists
+10 IF FILENUM=810.9
KILL DIQOUT(810.944)
+11 ;Don't transport the obsolete taxonomy fields.
+12 IF FILENUM=811.2
KILL DIQOUT(811.22102),DIQOUT(811.22103),DIQOUT(811.22104),DIQOUT(811.23102),DIQOUT(811.23104)
+13 ;TIU conversion for TIU/HS objects
+14 IF FILENUM=8925.1
IF FIELD="**"
DO TIUCONV(FILENUM,IEN,.DIQOUT)
+15 QUIT
+16 ;
+17 ;==========================
CMPLIST(CMPLIST,SELLIST,FILELST,ERROR) ;Process the selected list and build a
+1 ;complete list of components to be packed.
+2 NEW CIEN,IND,JND,FNUM,LRD,NUM,PACKLIST,ROUTINE
+3 SET ERROR=0
+4 FOR IND=1:1:FILELST(0)
Begin DoDot:1
+5 SET FNUM=$PIECE(FILELST(IND),U,1)
+6 IF '$DATA(SELLIST(FNUM))
QUIT
+7 SET ROUTINE=$$GETSRTN^PXRMEXPS(FNUM)_"(FNUM,CIEN,.PACKLIST)"
+8 SET NUM=0
+9 FOR
SET NUM=+$ORDER(SELLIST(FNUM,NUM))
IF NUM=0
QUIT
SET CIEN=SELLIST(FNUM,NUM)
DO @ROUTINE
End DoDot:1
+10 ;PACKLIST is built by following all pointers. Reversing the order
+11 ;for the Exchange install should allow resolution of pointers.
+12 SET FNUM=""
+13 FOR
SET FNUM=$ORDER(PACKLIST(FNUM))
IF FNUM=""
QUIT
Begin DoDot:1
+14 IF $DATA(PACKLIST(FNUM,"ERROR"))
Begin DoDot:2
+15 SET IND=0
SET ERROR=ERROR+1
+16 IF ERROR=1
WRITE !
+17 FOR
SET IND=+$ORDER(PACKLIST(FNUM,"ERROR",IND))
IF IND=0
QUIT
WRITE !,PACKLIST(FNUM,"ERROR",IND)," IEN=",IND
End DoDot:2
+18 SET IND="IEN"
SET JND=0
+19 FOR
SET IND=+$ORDER(PACKLIST(FNUM,IND),-1)
IF IND=0
QUIT
SET JND=JND+1
SET CMPLIST(FNUM,JND)=PACKLIST(FNUM,IND)
End DoDot:1
+20 ;If any definitions have a linked dialog add the linked dialog to the
+21 ;selection list so it can be marked as selected.
+22 IF '$DATA(CMPLIST(811.9))
QUIT
+23 SET NUM=$ORDER(SELLIST(801.41,"IEN"),-1)
+24 SET IND=0
+25 FOR
SET IND=$ORDER(CMPLIST(811.9,IND))
IF IND=""
QUIT
Begin DoDot:1
+26 SET LRD=$GET(^PXD(811.9,CMPLIST(811.9,IND),51))
+27 IF LRD'=""
SET NUM=NUM+1
SET SELLIST(801.41,NUM)=LRD
SET SELLIST(801.41,"IEN",LRD)=NUM
End DoDot:1
+28 IF ERROR
Begin DoDot:1
+29 WRITE !,"Cannot create the packed file due to the above error(s)."
+30 HANG 2
End DoDot:1
+31 QUIT
+32 ;
+33 ;==========================
CRE ;Pack a reminder component and store it in the repository.
+1 NEW CMPLIST,CNT,DIEN,DERRFND,DERRMSG,EFNAME,ERROR,FAIL,FAILTYPE,FILELST
+2 NEW OUTPUT,POA,RANK,SERROR,SELLIST,SUCCESS,TMPIND,USELLIST
+3 SET TMPIND="PXRMEXPR"
+4 KILL ^TMP(TMPIND,$JOB)
+5 SET FILELST(1)=811.4_U_$$GET1^DID(811.4,"","","NAME")
+6 SET FILELST(2)=810.8_U_$$GET1^DID(810.8,"","","NAME")
+7 SET FILELST(3)=811.9_U_$$GET1^DID(811.9,"","","NAME")
+8 SET FILELST(4)=801.41_U_$$GET1^DID(801.41,"","","NAME")
+9 SET FILELST(5)=810.7_U_$$GET1^DID(810.7,"","","NAME")
+10 SET FILELST(6)=810.2_U_$$GET1^DID(810.2,"","","NAME")
+11 SET FILELST(7)=810.4_U_$$GET1^DID(810.4,"","","NAME")
+12 SET FILELST(8)=810.9_U_$$GET1^DID(810.9,"","","NAME")
+13 SET FILELST(9)=811.6_U_$$GET1^DID(811.6,"","","NAME")
+14 SET FILELST(10)=811.2_U_$$GET1^DID(811.2,"","","NAME")
+15 SET FILELST(11)=811.5_U_$$GET1^DID(811.5,"","","NAME")
+16 SET FILELST(12)=801_U_$$GET1^DID(801,"","","NAME")
+17 SET FILELST(13)=801.1_U_$$GET1^DID(801.1,"","","NAME")
+18 SET FILELST(0)=13
+19 DO PACKORD(.RANK)
+20 ;
+21 ;Get the list to pack.
+22 DO FSEL(.SELLIST,.FILELST)
+23 ;
+24 KILL VALMHDR
+25 IF '$DATA(SELLIST)
SET VALMHDR(1)="No reminder items were selected!"
QUIT
+26 ;Save the user's selections.
+27 MERGE USELLIST=SELLIST
+28 ;Process the selected list to build a complete list of components
+29 ;to be packed.
+30 DO CMPLIST(.CMPLIST,.SELLIST,.FILELST,.ERROR)
+31 IF ERROR
KILL ^TMP(TMPIND,$JOB)
QUIT
+32 ;
+33 ;Check reminder dialogs for errors
+34 NEW FAILTYPE
+35 SET FAIL=0
+36 IF $DATA(SELLIST(801.41))
Begin DoDot:1
+37 WRITE !,"Checking reminder dialog(s) for errors."
+38 SET DIEN=0
+39 ;Check individual reminder dialogs
+40 FOR
SET DIEN=$ORDER(SELLIST(801.41,"IEN",DIEN))
IF DIEN'>0
QUIT
Begin DoDot:2
+41 IF FAIL=0
WRITE "."
+42 SET FAILTYPE=$$RETARR^PXRMDLRP(DIEN,.OUTPUT)
IF '$DATA(OUTPUT)
QUIT
+43 IF FAILTYPE="F"
SET FAIL="F"
+44 IF FAILTYPE="W"
IF FAIL=0
SET FAIL="W"
+45 WRITE !!,$SELECT(FAILTYPE="W":"**WARNING**",1:"**FATAL ERROR**")
+46 SET CNT=0
FOR
SET CNT=$ORDER(OUTPUT(CNT))
IF CNT'>0
QUIT
WRITE !,OUTPUT(CNT)
+47 KILL OUTPUT
End DoDot:2
+48 ;
+49 IF FAIL="W"
HANG 2
+50 IF FAIL=0
WRITE !,"No problems found."
HANG 1
QUIT
+51 IF FAIL="F"
WRITE !!,"Cannot create the packed file. Please correct the above fatal error(s)."
HANG 2
End DoDot:1
IF FAIL="F"
KILL ^TMP(TMPIND,$JOB)
QUIT
+52 ;
+53 ;Create the header information.
+54 DO HEADER(TMPIND,.USELLIST,.SELLIST,.RANK,.EFNAME)
+55 IF EFNAME=-1
QUIT
+56 ;
+57 ;Order the component list.
+58 DO ORDER(.CMPLIST,.RANK,.POA)
+59 ;Pack the list
+60 DO PACK(.CMPLIST,.POA,TMPIND,.SELLIST,.SERROR)
+61 IF SERROR
KILL ^TMP(TMPIND,$JOB)
QUIT
+62 ;Add information to the description about quick orders, TIU health
+63 ;summary objects, and health summaries that are included but are
+64 ;not exchangeable.
+65 DO NEXINFO(TMPIND)
+66 DO STOREPR^PXRMEXU2(.SUCCESS,EFNAME,TMPIND,.SELLIST)
+67 KILL ^TMP(TMPIND,$JOB)
+68 IF SUCCESS
Begin DoDot:1
+69 SET VALMHDR(1)=EFNAME_" was saved in the Exchange File."
+70 DO BLDLIST^PXRMEXLC(1)
End DoDot:1
+71 IF '$TEST
Begin DoDot:1
+72 SET VALMHDR(1)="Creation of Exchange File entry "_EFNAME
+73 SET VALMHDR(2)="failed; it was not saved!"
End DoDot:1
+74 QUIT
+75 ;
+76 ;==========================
FSEL(LIST,FILELST) ;Select file list.
+1 NEW ALIST,DIR,DIROUT,DIRUT,DONE,DTOUT,DUOUT,IND,X,Y
+2 FOR IND=1:1:FILELST(0)
SET ALIST(IND)=$$RJ^XLFSTR(IND,4," ")_" "_$PIECE(FILELST(IND),U,2)
+3 MERGE DIR("A")=ALIST
+4 SET DIR("A")="Select a file"
+5 SET DIR(0)="NO^1:"_FILELST(0)
+6 SET DONE=0
+7 FOR
IF DONE
QUIT
Begin DoDot:1
+8 WRITE !!,"Select from the following reminder files:"
+9 DO ^DIR
+10 IF (Y="")!(Y["^")
SET DONE=1
QUIT
+11 IF $DATA(DIROUT)!$DATA(DIRUT)
SET DONE=1
QUIT
+12 IF $DATA(DUOUT)!$DATA(DTOUT)
SET DONE=1
QUIT
+13 DO IENSEL(.LIST,Y,.FILELST)
End DoDot:1
+14 QUIT
+15 ;
+16 ;==========================
IENSEL(LIST,ID,FILELST) ;Select entries from the selected file.
+1 NEW DIC,DIR,DIROUT,DIRUT,DONE,DTOUT,DUOUT,FILENUM,NUMF,X,Y
+2 SET (DIC,FILENUM)=$PIECE(FILELST(ID),U,1)
+3 SET NUMF=+$ORDER(LIST(FILENUM,""),-1)
+4 SET DIC(0)="QEA"
+5 SET DONE=0
+6 FOR
IF DONE
QUIT
Begin DoDot:1
+7 DO ^DIC
+8 IF Y=-1
SET DONE=1
QUIT
+9 IF $DATA(DIROUT)!$DATA(DIRUT)
SET DONE=1
QUIT
+10 IF $DATA(DUOUT)!$DATA(DTOUT)
SET DONE=1
QUIT
+11 SET NUMF=NUMF+1
+12 SET LIST(FILENUM,NUMF)=+Y
+13 SET LIST(FILENUM,"IEN",+Y)=NUMF
+14 WRITE !,"Enter another one or just press enter to go back to file selection."
End DoDot:1
+15 QUIT
+16 ;
+17 ;==========================
GETTEXT(FILENUM,IEN,TMPIND,INDEX) ;Let the user input some text.
+1 NEW DIC,DWLW,DWPK,FIELDNUM,TYPE
+2 ;If this is the description text, (signfied by FILENUM>0) load the
+3 ;description or short description as the default.
+4 IF FILENUM>0
Begin DoDot:1
+5 SET FIELDNUM=$$FLDNUM^DILFD(FILENUM,"DESCRIPTION")
SET TYPE="WP"
+6 IF FIELDNUM=0
SET FIELDNUM=$$FLDNUM^DILFD(FILENUM,"SHORT DESCRIPTION")
SET TYPE="SD"
End DoDot:1
+7 IF '$TEST
SET FIELDNUM=0
+8 IF FIELDNUM>0
Begin DoDot:1
+9 NEW MSG,WP,X
+10 IF TYPE="WP"
Begin DoDot:2
+11 SET X=$$GET1^DIQ(FILENUM,IEN,FIELDNUM,"Z","WP","MSG")
+12 MERGE ^TMP(TMPIND,$JOB,INDEX,1)=WP
End DoDot:2
+13 IF TYPE="SD"
Begin DoDot:2
+14 SET X=$$GET1^DIQ(FILENUM,IEN,FIELDNUM,"","","MSG")
+15 SET ^TMP(TMPIND,$JOB,INDEX,1,1,0)=X
End DoDot:2
End DoDot:1
+16 SET DIC="^TMP(TMPIND,$J,"""_INDEX_""",1,"
+17 SET DWLW=72
SET DWPK=1
+18 DO EN^DIWE
+19 QUIT
+20 ;
+21 ;==========================
GDIQF(FILENUM,FILENAME,IEN,IND,TMPIND,SELLIST,SERROR) ;Save file entries into
+1 ;^TMP(TMPIND,$J).
+2 NEW CSUM,DIQOUT,IENROOT,FIELD,MSG,NUM
+3 KILL DIQOUT,IENROOT
+4 ;If the file entry is ok to install then get the entire entry,
+5 ;otherwise just get the .01.
+6 SET FIELD=$SELECT($$IOKTP^PXRMEXFI(FILENUM,IEN):"**",1:.01)
+7 ;
+8 ;Items from file 142, 142.5, and 8925.1 need to be added to the
+9 ;SELLIST array if $$IOKTP returns "**". These items are IEN specific
+10 ;and the check needs to be done at time of packing this is why they
+11 ;are added to SELLIST.
+12 IF ((FILENUM=142)!(FILENUM=142.5)!(FILENUM=8925.1))&(FIELD="**")
Begin DoDot:1
+13 SET NUM=$ORDER(SELLIST(FILENUM,"IEN",""),-1)
+14 SET NUM=NUM+1
SET SELLIST(FILENUM,"IEN",IEN)=NUM
SET SELLIST(FILENUM,NUM)=IEN
End DoDot:1
+15 ;
+16 DO GETS^DIQ(FILENUM,IEN,FIELD,"N","DIQOUT","MSG")
+17 IF $DATA(MSG)
Begin DoDot:1
+18 SET SERROR=1
+19 NEW ETEXT
+20 SET ETEXT="GETS^DIQ failed for "_FILENAME_", ien="_IEN_";"
+21 WRITE !,ETEXT
+22 WRITE !,"it returned the following error:"
+23 DO AWRITE^PXRMUTIL("MSG")
+24 HANG 2
+25 KILL MSG
End DoDot:1
QUIT
+26 DO CLDIQOUT(FILENUM,IEN,FIELD,.IENROOT,.DIQOUT)
+27 SET ^TMP("PXRMEXCS",$JOB,IND,FILENAME)=$$DIQOUTCS^PXRMEXCS(.DIQOUT)
+28 ;Load the converted DIQOUT into TMP.
+29 MERGE ^TMP(TMPIND,$JOB,IND,FILENAME)=DIQOUT
+30 MERGE ^TMP(TMPIND,$JOB,IND,FILENAME_"_IENROOT")=IENROOT
+31 QUIT
+32 ;
+33 ;==========================
GRTN(ROUTINE,TMPIND,SERROR) ;Save routines into ^TMP(TMPIND,$J).
+1 NEW DIF,IEN,IND,RA,TEMP,X,XCNP
+2 SET X=ROUTINE
+3 XECUTE ^%ZOSF("TEST")
+4 IF $TEST
Begin DoDot:1
+5 KILL RA
+6 SET DIF="RA("
+7 SET XCNP=0
+8 XECUTE ^%ZOSF("LOAD")
+9 SET ^TMP("PXRMEXCS",$JOB,"ROUTINE",X)=$$ROUTINE^PXRMEXCS(.RA)
+10 MERGE ^TMP(TMPIND,$JOB,"ROUTINE",X)=RA
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 SET SERROR=1
+13 WRITE !,"Warning could not find routine ",X
+14 HANG 2
End DoDot:1
+15 QUIT
+16 ;
+17 ;==========================
+1 ;information.
+2 NEW DIR,EXTYPE,IEN,IND,FILENAME,FILENUM,NFNUM,NIEN,PNAME,Y
+3 SET (FILENAME,FILENUM,IEN,NIEN)=""
SET NFNUM=0
+4 FOR
SET FILENUM=$ORDER(USELLIST(FILENUM))
IF FILENUM=""
QUIT
SET NFNUM=NFNUM+1
+5 IF NFNUM=1
Begin DoDot:1
+6 SET FILENUM=$ORDER(USELLIST(""))
+7 SET IND=""
SET NIEN=0
+8 FOR
SET IND=$ORDER(USELLIST(FILENUM,IND))
IF IND="IEN"
QUIT
SET NIEN=NIEN+1
+9 IF NIEN=1
Begin DoDot:2
+10 SET IND=$ORDER(USELLIST(FILENUM,""))
+11 SET IEN=USELLIST(FILENUM,IND)
+12 SET NAME=$$GET1^DIQ(FILENUM,IEN,.01)
+13 SET FILENAME=$$GET1^DID(FILENUM,"","","NAME")
+14 ;If only one item was selected make it the default.
+15 SET DIR("B")=NAME
End DoDot:2
End DoDot:1
+16 ;Get the Exchange file entry name.
+17 SET DIR(0)="FAU^3:64"
+18 SET DIR("A")="Enter the Exchange File entry name: "
+19 DO ^DIR
+20 IF (Y="")!($DATA(DTOUT))!($DATA(DUOUT))
SET EFNAME=-1
QUIT
+21 SET EFNAME=Y
+22 KILL DIR
+23 ;Save the source information.
+24 DO PUTSRC(FILENAME,EFNAME,TMPIND)
+25 SET PNAME=$SELECT(NIEN=1:FILENAME,1:"Exchange File entry")
+26 ;If multiple items were selected for packing initialize the
+27 ;description with the selection list.
+28 IF (NFNUM>1)!(NIEN>1)
DO BLDDESC(.USELLIST,TMPIND)
+29 ;If a single item was selected the description will be initialized
+30 ;with the selected item's description. In either case the user can
+31 ;input additional description text.
+32 WRITE !,"Enter a description of the ",PNAME," you are packing."
HANG 2
+33 DO GETTEXT(FILENUM,IEN,TMPIND,"DESC")
+34 ;
+35 ;Have the user input keywords for indexing the entry.
+36 WRITE !,"Enter keywords or phrases to help index the entry you are packing."
+37 WRITE !,"Separate the keywords or phrases on each line with commas."
HANG 2
+38 DO GETTEXT(0,0,TMPIND,"KEYWORD")
+39 ;
+40 ;Combine the source and input text into the "TEXT" array.
+41 DO BLDTEXT(TMPIND)
+42 QUIT
+43 ;
+44 ;==========================
NEXINFO(TMPIND) ;Add information to the description about quick orders,
+1 ;TIU health summary objects, and health summaries that are included
+2 ;but are not exchangeable.
+3 NEW NL,NLS
+4 SET (NL,NLS)=$PIECE($GET(^TMP(TMPIND,$JOB,"DESC",1,0)),U,4)
+5 IF $DATA(^TMP($JOB,"ORDER DIALOG"))
Begin DoDot:1
+6 IF NL>NLS
SET NL=NL+1
SET ^TMP(TMPIND,$JOB,"DESC",1,NL,0)=""
+7 SET NL=NL+1
SET ^TMP(TMPIND,$JOB,"DESC",1,NL,0)="Non-exchangeable order dialog(s):"
+8 DO NEXINFOA(TMPIND,"ORDER DIALOG",.NL)
End DoDot:1
+9 IF $DATA(^TMP($JOB,"TIU OBJECT"))
Begin DoDot:1
+10 IF NL>NLS
SET NL=NL+1
SET ^TMP(TMPIND,$JOB,"DESC",1,NL,0)=""
+11 SET NL=NL+1
SET ^TMP(TMPIND,$JOB,"DESC",1,NL,0)="Non-exchangeable TIU object(s):"
+12 DO NEXINFOA(TMPIND,"TIU OBJECT",.NL)
End DoDot:1
+13 IF $DATA(^TMP($JOB,"HS OBJECT"))
Begin DoDot:1
+14 IF NL>NLS
SET NL=NL+1
SET ^TMP(TMPIND,$JOB,"DESC",1,NL,0)=""
+15 SET NL=NL+1
SET ^TMP(TMPIND,$JOB,"DESC",1,NL,0)="Non-exchangeable health summary object(s):"
+16 DO NEXINFOA(TMPIND,"HS OBJECT",.NL)
End DoDot:1
+17 IF $DATA(^TMP($JOB,"HS TYPE"))
Begin DoDot:1
+18 IF NL>NLS
SET NL=NL+1
SET ^TMP(TMPIND,$JOB,"DESC",1,NL,0)=""
+19 SET NL=NL+1
SET ^TMP(TMPIND,$JOB,"DESC",1,NL,0)="Non-exchangeable health summary type(s):"
+20 DO NEXINFOA(TMPIND,"HS TYPE",.NL)
End DoDot:1
+21 IF $DATA(^TMP($JOB,"HS COMP"))
Begin DoDot:1
+22 IF NL>NLS
SET NL=NL+1
SET ^TMP(TMPIND,$JOB,"DESC",1,NL,0)=""
+23 SET NL=NL+1
SET ^TMP(TMPIND,$JOB,"DESC",1,NL,0)="Non-exchangeable health summary component(s):"
+24 DO NEXINFOA(TMPIND,"HS COMP",.NL)
End DoDot:1
+25 IF $DATA(^TMP($JOB,"LOCATION LIST"))
Begin DoDot:1
+26 IF NL>NLS
SET NL=NL+1
SET ^TMP(TMPIND,$JOB,"DESC",1,NL,0)=""
+27 SET NL=NL+1
SET ^TMP(TMPIND,$JOB,"DESC",1,NL,0)="Non-exchangeable location list hospital locations:"
+28 DO NEXINFOA(TMPIND,"LOCATION LIST",.NL)
End DoDot:1
+29 IF NL>NLS
SET $PIECE(^TMP(TMPIND,$JOB,"DESC",1,0),U,3,4)=NL_U_NL
+30 QUIT
+31 ;
+32 ;==========================
NEXINFOA(TMPIND,SUB,NL) ;
+1 NEW IEN,LNUM
+2 IF SUB'["ORDER"
SET NL=NL+1
SET ^TMP(TMPIND,$JOB,"DESC",1,NL,0)=$$REPEAT^XLFSTR("-",79)
+3 SET IEN=0
+4 FOR
SET IEN=$ORDER(^TMP($JOB,SUB,IEN))
IF IEN'>0
QUIT
Begin DoDot:1
+5 SET LNUM=0
+6 FOR
SET LNUM=$ORDER(^TMP($JOB,SUB,IEN,LNUM))
IF LNUM=""
QUIT
Begin DoDot:2
+7 SET NL=NL+1
SET ^TMP(TMPIND,$JOB,"DESC",1,NL,0)=^TMP($JOB,SUB,IEN,LNUM)
End DoDot:2
End DoDot:1
+8 IF SUB'["ORDER"
SET NL=NL+1
SET ^TMP(TMPIND,$JOB,"DESC",1,NL,0)=$$REPEAT^XLFSTR("-",79)
+9 KILL ^TMP($JOB,SUB)
+10 QUIT
+11 ;
+12 ;==========================
ORDER(CMPLIST,RANK,POA) ;Order the component list so pointers can be resolved.
+1 NEW FILENUM,ORDER,PORDER
+2 SET FILENUM=""
SET ORDER=0
+3 FOR
SET FILENUM=$ORDER(CMPLIST(FILENUM))
IF FILENUM=""
QUIT
Begin DoDot:1
+4 SET PORDER=$GET(RANK("FN",FILENUM))
+5 IF PORDER=""
SET ORDER=ORDER+1
SET PORDER=ORDER
+6 SET POA(PORDER)=FILENUM
End DoDot:1
+7 QUIT
+8 ;
+9 ;==========================
PACK(CMPLIST,POA,TMPIND,SELLIST,SERROR) ;Create the packed entry, store it in
+1 ;^TMP(TMPIND,$J). TMPIND should be namespaced and set by the caller.
+2 NEW IEN,IND,JND,KND,FILENAME,FILENUM,ROUTINE
+3 WRITE !,"Packing components ..."
+4 SET (KND,SERROR)=0
+5 SET IND=""
+6 FOR
SET IND=$ORDER(POA(IND))
IF IND=""
QUIT
Begin DoDot:1
+7 SET FILENUM=POA(IND)
+8 SET FILENAME=$SELECT(FILENUM=0:"ROUTINE",1:$$GET1^DID(FILENUM,"","","NAME"))
+9 SET JND=""
+10 FOR
SET JND=$ORDER(CMPLIST(FILENUM,JND))
IF JND=""
QUIT
Begin DoDot:2
+11 SET IEN=CMPLIST(FILENUM,JND)
+12 IF FILENUM=0
WRITE !,"Adding routine ",IEN
+13 IF '$TEST
WRITE !,"Adding ",FILENAME," ",$$GET1^DIQ(FILENUM,IEN,.01),", IEN=",IEN
+14 IF FILENUM=0
DO GRTN(IEN,TMPIND,.SERROR)
+15 IF FILENUM>0
SET KND=KND+1
DO GDIQF(FILENUM,FILENAME,IEN,KND,TMPIND,.SELLIST,.SERROR)
End DoDot:2
End DoDot:1
+16 ;
+17 SET ^TMP(TMPIND,$JOB,"NUMF")=KND
+18 WRITE !,"Packing is complete."
+19 ;If there were any errors saving the data kill the ^TMP array.
+20 IF SERROR
KILL ^TMP(TMPIND,$JOB)
+21 QUIT
+22 ;
+23 ;==========================
PACKORD(RANK) ;
+1 SET RANK("FN",801.41)=7000
SET RANK(7000)=801.41
+2 SET RANK("FN",810.2)=11000
SET RANK(11000)=810.2
+3 SET RANK("FN",810.4)=8000
SET RANK(8000)=810.4
+4 SET RANK("FN",810.7)=10000
SET RANK(10000)=810.7
+5 SET RANK("FN",810.8)=9000
SET RANK(9000)=810.8
+6 SET RANK("FN",810.9)=4000
SET RANK(4000)=810.9
+7 SET RANK("FN",811.2)=3000
SET RANK(3000)=811.2
+8 SET RANK("FN",811.4)=2000
SET RANK(2000)=811.4
+9 SET RANK("FN",811.5)=5000
SET RANK(5000)=811.5
+10 SET RANK("FN",811.6)=1000
SET RANK(1000)=811.6
+11 SET RANK("FN",811.9)=6000
SET RANK(6000)=811.9
+12 SET RANK("FN",142.1)=100000
SET RANK(100000)=142.1
+13 SET RANK("FN",142)=100100
SET RANK(100100)=142
+14 SET RANK("FN",142.5)=100200
SET RANK(100200)=142.5
+15 SET RANK("FN",8925.1)=100300
SET RANK(100300)=8925.1
+16 SET RANK("FN",801)=100500
SET RANK(100500)=801
+17 SET RANK("FN",801.1)=100400
SET RANK(100400)=801.1
+18 QUIT
+19 ;
+20 ;==========================
PUTSRC(FILENAME,NAME,TMPIND) ;Save the source information.
+1 NEW LOC
+2 SET LOC=$$SITE^VASITE
+3 IF FILENAME'=""
SET ^TMP(TMPIND,$JOB,"SRC","FILENAME")=FILENAME
+4 SET ^TMP(TMPIND,$JOB,"SRC","NAME")=NAME
+5 SET ^TMP(TMPIND,$JOB,"SRC","USER")=$$GET1^DIQ(200,DUZ,.01)
+6 SET ^TMP(TMPIND,$JOB,"SRC","SITE")=$PIECE(LOC,U,2)
+7 SET ^TMP(TMPIND,$JOB,"SRC","DATE")=$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
+8 QUIT
+9 ;
+10 ;==========================
TIUCONV(FILENUM,IEN,ARRAY) ;Convert health summary object to external.
+1 NEW HSO,IENS,NAME
+2 SET IENS="+"_IEN_","
+3 ;Allows non-objects to be packed up
+4 IF ARRAY(FILENUM,IENS,.04)'="OBJECT"
QUIT
+5 ;
+6 IF $GET(ARRAY(FILENUM,IENS,9))'["$$TIU^GMTSOBJ"
Begin DoDot:1
+7 SET ARRAY(FILENUM,IENS,9)="NOT A HS OBJECT"
End DoDot:1
QUIT
+8 SET HSO=$PIECE(ARRAY(FILENUM,IENS,9),",",2)
+9 SET HSO=$PIECE(HSO,")")
+10 ;Handle corrupted health summary object names.
+11 IF +HSO>0
SET NAME=$PIECE($GET(^GMT(142.5,HSO,0)),U,1)
+12 IF '$TEST
SET NAME="MISSING"
+13 SET ARRAY(FILENUM,IENS,9)="S X=$$TIU^GMTSOBJ(DFN,"_NAME_")"
+14 SET ARRAY(FILENUM,IENS,99)=""
+15 QUIT
+16 ;
