PXRMEXPD ;SLC/PKR - General packing driver. ;07/31/2020
;;2.0;CLINICAL REMINDERS;**12,17,16,18,22,26,45,42**;Feb 04, 2005;Build 245
;==========================
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^PXRMEXPU(FILENUM,IEN,.DIQOUT)
I FILENUM=801.46,FIELD="**" D DIALOGGF^PXRMEXPU(FILENUM,IEN,.DIQOUT)
Q
;
;==========================
CMPLIST(CMPLIST,SELLIST,FILELST,ERROR) ;Process the selected list and build a
;complete list of components to be packed.
K ^TMP($J,"PXRM DIALOG CHILDREN")
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
;
;remove any dialog selection that is a child of another dialog selection
S CIEN=0 F S CIEN=$O(SELLIST(801.41,"IEN",CIEN)) Q:CIEN'>0 D
.I '$D(^TMP($J,"PXRM DIALOG CHILDREN",CIEN)) Q
.S NUM=SELLIST(801.41,"IEN",CIEN)
.K SELLIST(801.41,"IEN",CIEN),SELLIST(801.41,NUM)
K ^TMP($J,"PXRM DIALOG CHILDREN")
;
;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(REPACK,EXNAME,NOTINLM) ;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.
I $D(REPACK) M SELLIST=REPACK
I '$D(REPACK) 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
;
DEF ;Check reminder definitions for errors.
N OK,OUTPUT
S FAIL=0
I $D(SELLIST(811.9)) D I FAIL K ^TMP(TMPIND,$J) Q
.;Check each reminder definition.
. W !!,"Checking reminder definition(s) for errors."
. S DIEN=0
. F S DIEN=$O(SELLIST(811.9,"IEN",DIEN)) Q:DIEN'>0 D
.. W !!,"Checking reminder definition "_$P(^PXD(811.9,DIEN,0),U,1)
.. K OUTPUT
.. S OK=$$DEF^PXRMICHK(DIEN,.OUTPUT,1)
.. I OK=0 S FAIL=1
. I FAIL=0 W !!,"No fatal reminder definition problems were found, packing will continue."
. I FAIL=1 W !!,"Cannot create the packed file, please correct the above fatal error(s)."
. H 3
;
TERM ;Check reminder terms for errors.
S FAIL=0
I $D(SELLIST(811.5)) D I FAIL K ^TMP(TMPIND,$J) Q
.;Check each reminder term.
. W !!,"Checking reminder term(s) for errors."
. S DIEN=0
. F S DIEN=$O(SELLIST(811.5,"IEN",DIEN)) Q:DIEN'>0 D
.. W !!,"Checking reminder term "_$P(^PXRMD(811.5,DIEN,0),U,1)
.. K OUTPUT
.. S OK=$$TERM^PXRMICK1(DIEN,.OUTPUT,1)
.. I OK=0 S FAIL=1
. I FAIL=0 W !!,"No fatal reminder term problems were found, packing will continue."
. I FAIL=1 W !!,"Cannot create the packed file, please correct the above fatal error(s)."
. H 3
;
DIALOG ;Check reminder dialogs for errors
N FAILTYPE
S FAIL=0
K OUTPUT
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**",FAILTYPE="F":"**FATAL ERROR**",1:"")
.. S CNT=0 F S CNT=$O(OUTPUT(CNT)) Q:CNT'>0 W !,OUTPUT(CNT)
.. K OUTPUT
.;
. I FAIL=0 W !!,"No fatal dialog problems were found, packing will continue."
. I FAIL="F" W !!,"Cannot create the packed file, please correct the above fatal error(s)."
. H 3
;
;Create the header information.
S EFNAME=$S($G(EXNAME)'="":EXNAME,1:"")
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
. I +$G(NOTINLM) W !,EFNAME_" was saved in the Exchange File." Q
. S VALMHDR(1)=EFNAME_" was saved in the Exchange File."
. D BLDLIST^PXRMEXLC(1)
E D
. I +$G(NOTINLM) D Q
..W !,"Creation of Exchange File entry "_EFNAME
..W !,"failed; it was not saved!"
. 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: "
;If this is a repack, EFNAME will be the name of the entry being
;repacked.
I $G(EFNAME)'="" S DIR("B")=EFNAME
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)
;
;Add the packing attributes.
D PATTR(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)=200000,RANK(200000)=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
;
;==========================
PATTR(TMPIND) ;Build a list of packing attributes.
S ^TMP(TMPIND,$J,"PATTR",1)="GROUPING DIALOG COMPONENTS"
Q
;
;==========================
PUTSRC(FILENAME,NAME,TMPIND) ;Save the source information.
N LOC,Y
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")
D GETENV^%ZOSV
S ^TMP(TMPIND,$J,"SRC","ENV")=Y
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMEXPD 18407 printed Oct 16, 2024@17:46:01 Page 2
PXRMEXPD ;SLC/PKR - General packing driver. ;07/31/2020
+1 ;;2.0;CLINICAL REMINDERS;**12,17,16,18,22,26,45,42**;Feb 04, 2005;Build 245
+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^PXRMEXPU(FILENUM,IEN,.DIQOUT)
+15 IF FILENUM=801.46
IF FIELD="**"
DO DIALOGGF^PXRMEXPU(FILENUM,IEN,.DIQOUT)
+16 QUIT
+17 ;
+18 ;==========================
CMPLIST(CMPLIST,SELLIST,FILELST,ERROR) ;Process the selected list and build a
+1 ;complete list of components to be packed.
+2 KILL ^TMP($JOB,"PXRM DIALOG CHILDREN")
+3 NEW CIEN,IND,JND,FNUM,LRD,NUM,PACKLIST,ROUTINE
+4 SET ERROR=0
+5 FOR IND=1:1:FILELST(0)
Begin DoDot:1
+6 SET FNUM=$PIECE(FILELST(IND),U,1)
+7 IF '$DATA(SELLIST(FNUM))
QUIT
+8 SET ROUTINE=$$GETSRTN^PXRMEXPS(FNUM)_"(FNUM,CIEN,.PACKLIST)"
+9 SET NUM=0
+10 FOR
SET NUM=+$ORDER(SELLIST(FNUM,NUM))
if NUM=0
QUIT
SET CIEN=SELLIST(FNUM,NUM)
DO @ROUTINE
End DoDot:1
+11 ;
+12 ;remove any dialog selection that is a child of another dialog selection
+13 SET CIEN=0
FOR
SET CIEN=$ORDER(SELLIST(801.41,"IEN",CIEN))
if CIEN'>0
QUIT
Begin DoDot:1
+14 IF '$DATA(^TMP($JOB,"PXRM DIALOG CHILDREN",CIEN))
QUIT
+15 SET NUM=SELLIST(801.41,"IEN",CIEN)
+16 KILL SELLIST(801.41,"IEN",CIEN),SELLIST(801.41,NUM)
End DoDot:1
+17 KILL ^TMP($JOB,"PXRM DIALOG CHILDREN")
+18 ;
+19 ;PACKLIST is built by following all pointers. Reversing the order
+20 ;for the Exchange install should allow resolution of pointers.
+21 SET FNUM=""
+22 FOR
SET FNUM=$ORDER(PACKLIST(FNUM))
if FNUM=""
QUIT
Begin DoDot:1
+23 IF $DATA(PACKLIST(FNUM,"ERROR"))
Begin DoDot:2
+24 SET IND=0
SET ERROR=ERROR+1
+25 IF ERROR=1
WRITE !
+26 FOR
SET IND=+$ORDER(PACKLIST(FNUM,"ERROR",IND))
if IND=0
QUIT
WRITE !,PACKLIST(FNUM,"ERROR",IND)," IEN=",IND
End DoDot:2
+27 SET IND="IEN"
SET JND=0
+28 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
+29 ;If any definitions have a linked dialog add the linked dialog to the
+30 ;selection list so it can be marked as selected.
+31 IF '$DATA(CMPLIST(811.9))
QUIT
+32 SET NUM=$ORDER(SELLIST(801.41,"IEN"),-1)
+33 SET IND=0
+34 FOR
SET IND=$ORDER(CMPLIST(811.9,IND))
if IND=""
QUIT
Begin DoDot:1
+35 SET LRD=$GET(^PXD(811.9,CMPLIST(811.9,IND),51))
+36 IF LRD'=""
SET NUM=NUM+1
SET SELLIST(801.41,NUM)=LRD
SET SELLIST(801.41,"IEN",LRD)=NUM
End DoDot:1
+37 IF ERROR
Begin DoDot:1
+38 WRITE !,"Cannot create the packed file due to the above error(s)."
+39 HANG 2
End DoDot:1
+40 QUIT
+41 ;
+42 ;==========================
CRE(REPACK,EXNAME,NOTINLM) ;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 IF $DATA(REPACK)
MERGE SELLIST=REPACK
+23 IF '$DATA(REPACK)
DO FSEL(.SELLIST,.FILELST)
+24 ;
+25 KILL VALMHDR
+26 IF '$DATA(SELLIST)
SET VALMHDR(1)="No reminder items were selected!"
QUIT
+27 ;Save the user's selections.
+28 MERGE USELLIST=SELLIST
+29 ;Process the selected list to build a complete list of components
+30 ;to be packed.
+31 DO CMPLIST(.CMPLIST,.SELLIST,.FILELST,.ERROR)
+32 IF ERROR
KILL ^TMP(TMPIND,$JOB)
QUIT
+33 ;
DEF ;Check reminder definitions for errors.
+1 NEW OK,OUTPUT
+2 SET FAIL=0
+3 IF $DATA(SELLIST(811.9))
Begin DoDot:1
+4 ;Check each reminder definition.
+5 WRITE !!,"Checking reminder definition(s) for errors."
+6 SET DIEN=0
+7 FOR
SET DIEN=$ORDER(SELLIST(811.9,"IEN",DIEN))
if DIEN'>0
QUIT
Begin DoDot:2
+8 WRITE !!,"Checking reminder definition "_$PIECE(^PXD(811.9,DIEN,0),U,1)
+9 KILL OUTPUT
+10 SET OK=$$DEF^PXRMICHK(DIEN,.OUTPUT,1)
+11 IF OK=0
SET FAIL=1
End DoDot:2
+12 IF FAIL=0
WRITE !!,"No fatal reminder definition problems were found, packing will continue."
+13 IF FAIL=1
WRITE !!,"Cannot create the packed file, please correct the above fatal error(s)."
+14 HANG 3
End DoDot:1
IF FAIL
KILL ^TMP(TMPIND,$JOB)
QUIT
+15 ;
TERM ;Check reminder terms for errors.
+1 SET FAIL=0
+2 IF $DATA(SELLIST(811.5))
Begin DoDot:1
+3 ;Check each reminder term.
+4 WRITE !!,"Checking reminder term(s) for errors."
+5 SET DIEN=0
+6 FOR
SET DIEN=$ORDER(SELLIST(811.5,"IEN",DIEN))
if DIEN'>0
QUIT
Begin DoDot:2
+7 WRITE !!,"Checking reminder term "_$PIECE(^PXRMD(811.5,DIEN,0),U,1)
+8 KILL OUTPUT
+9 SET OK=$$TERM^PXRMICK1(DIEN,.OUTPUT,1)
+10 IF OK=0
SET FAIL=1
End DoDot:2
+11 IF FAIL=0
WRITE !!,"No fatal reminder term problems were found, packing will continue."
+12 IF FAIL=1
WRITE !!,"Cannot create the packed file, please correct the above fatal error(s)."
+13 HANG 3
End DoDot:1
IF FAIL
KILL ^TMP(TMPIND,$JOB)
QUIT
+14 ;
DIALOG ;Check reminder dialogs for errors
+1 NEW FAILTYPE
+2 SET FAIL=0
+3 KILL OUTPUT
+4 IF $DATA(SELLIST(801.41))
Begin DoDot:1
+5 WRITE !!,"Checking reminder dialog(s) for errors."
+6 SET DIEN=0
+7 ;Check individual reminder dialogs
+8 FOR
SET DIEN=$ORDER(SELLIST(801.41,"IEN",DIEN))
if DIEN'>0
QUIT
Begin DoDot:2
+9 IF FAIL=0
WRITE "."
+10 SET FAILTYPE=$$RETARR^PXRMDLRP(DIEN,.OUTPUT)
if '$DATA(OUTPUT)
QUIT
+11 IF FAILTYPE="F"
SET FAIL="F"
+12 IF FAILTYPE="W"
IF FAIL=0
SET FAIL="W"
+13 WRITE !!,$SELECT(FAILTYPE="W":"**WARNING**",FAILTYPE="F":"**FATAL ERROR**",1:"")
+14 SET CNT=0
FOR
SET CNT=$ORDER(OUTPUT(CNT))
if CNT'>0
QUIT
WRITE !,OUTPUT(CNT)
+15 KILL OUTPUT
End DoDot:2
+16 ;
+17 IF FAIL=0
WRITE !!,"No fatal dialog problems were found, packing will continue."
+18 IF FAIL="F"
WRITE !!,"Cannot create the packed file, please correct the above fatal error(s)."
+19 HANG 3
End DoDot:1
IF FAIL="F"
KILL ^TMP(TMPIND,$JOB)
QUIT
+20 ;
+21 ;Create the header information.
+22 SET EFNAME=$SELECT($GET(EXNAME)'="":EXNAME,1:"")
+23 DO HEADER(TMPIND,.USELLIST,.SELLIST,.RANK,.EFNAME)
+24 IF EFNAME=-1
QUIT
+25 ;
+26 ;Order the component list.
+27 DO ORDER(.CMPLIST,.RANK,.POA)
+28 ;Pack the list
+29 DO PACK(.CMPLIST,.POA,TMPIND,.SELLIST,.SERROR)
+30 IF SERROR
KILL ^TMP(TMPIND,$JOB)
QUIT
+31 ;Add information to the description about quick orders, TIU health
+32 ;summary objects, and health summaries that are included but are
+33 ;not exchangeable.
+34 DO NEXINFO(TMPIND)
+35 DO STOREPR^PXRMEXU2(.SUCCESS,EFNAME,TMPIND,.SELLIST)
+36 KILL ^TMP(TMPIND,$JOB)
+37 IF SUCCESS
Begin DoDot:1
+38 IF +$GET(NOTINLM)
WRITE !,EFNAME_" was saved in the Exchange File."
QUIT
+39 SET VALMHDR(1)=EFNAME_" was saved in the Exchange File."
+40 DO BLDLIST^PXRMEXLC(1)
End DoDot:1
+41 IF '$TEST
Begin DoDot:1
+42 IF +$GET(NOTINLM)
Begin DoDot:2
+43 WRITE !,"Creation of Exchange File entry "_EFNAME
+44 WRITE !,"failed; it was not saved!"
End DoDot:2
QUIT
+45 SET VALMHDR(1)="Creation of Exchange File entry "_EFNAME
+46 SET VALMHDR(2)="failed; it was not saved!"
End DoDot:1
+47 QUIT
+48 ;
+49 ;==========================
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 ;If this is a repack, EFNAME will be the name of the entry being
+20 ;repacked.
+21 IF $GET(EFNAME)'=""
SET DIR("B")=EFNAME
+22 DO ^DIR
+23 IF (Y="")!($DATA(DTOUT))!($DATA(DUOUT))
SET EFNAME=-1
QUIT
+24 SET EFNAME=Y
+25 KILL DIR
+26 ;Save the source information.
+27 DO PUTSRC(FILENAME,EFNAME,TMPIND)
+28 SET PNAME=$SELECT(NIEN=1:FILENAME,1:"Exchange File entry")
+29 ;If multiple items were selected for packing initialize the
+30 ;description with the selection list.
+31 IF (NFNUM>1)!(NIEN>1)
DO BLDDESC(.USELLIST,TMPIND)
+32 ;If a single item was selected the description will be initialized
+33 ;with the selected item's description. In either case the user can
+34 ;input additional description text.
+35 WRITE !,"Enter a description of the ",PNAME," you are packing."
HANG 2
+36 DO GETTEXT(FILENUM,IEN,TMPIND,"DESC")
+37 ;
+38 ;Have the user input keywords for indexing the entry.
+39 WRITE !,"Enter keywords or phrases to help index the entry you are packing."
+40 WRITE !,"Separate the keywords or phrases on each line with commas."
HANG 2
+41 DO GETTEXT(0,0,TMPIND,"KEYWORD")
+42 ;
+43 ;Combine the source and input text into the "TEXT" array.
+44 DO BLDTEXT(TMPIND)
+45 ;
+46 ;Add the packing attributes.
+47 DO PATTR(TMPIND)
+48 QUIT
+49 ;
+50 ;==========================
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)=200000
SET RANK(200000)=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 ;==========================
PATTR(TMPIND) ;Build a list of packing attributes.
+1 SET ^TMP(TMPIND,$JOB,"PATTR",1)="GROUPING DIALOG COMPONENTS"
+2 QUIT
+3 ;
+4 ;==========================
PUTSRC(FILENAME,NAME,TMPIND) ;Save the source information.
+1 NEW LOC,Y
+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 DO GETENV^%ZOSV
+9 SET ^TMP(TMPIND,$JOB,"SRC","ENV")=Y
+10 QUIT
+11 ;
