PXRMEXPS ; SLC/PKR - Packing save routines. ;13-Aug-2015 12:06;du
;;2.0;CLINICAL REMINDERS;**12,16,18,22,24,26,1005**;Feb 04, 2005;Build 23
;==========================================
ADD(FILENUM,IEN,PACKLIST,NF) ;
S NF=+$O(PACKLIST(FILENUM,"IEN"),-1)+1
S PACKLIST(FILENUM,NF)=IEN
S PACKLIST(FILENUM,"IEN",IEN)=NF
Q
;
;==========================================
CHKCF(ROOT,TOPIEN,GBL,PACKLIST) ;
N IEN,NAME,NUM,PARM,RIEN,ROUTINE
S IEN=""
F S IEN=$O(@ROOT@(TOPIEN,20,"E",GBL,IEN)) Q:IEN="" D
. I $P($G(^PXRMD(811.4,IEN,0)),U,1)'="VA-REMINDER DEFINITION" Q
. S NUM=$O(@ROOT@(TOPIEN,20,"E",GBL,IEN,"")) Q:NUM'>0
. S PARM=$P($G(@ROOT@(TOPIEN,20,NUM,15)),U,1)
. S NAME=$P(PARM,U,1)
. S RIEN=$O(^PXD(811.9,"B",NAME,"")) Q:RIEN'>0
. S ROUTINE=$$GETSRTN(811.9)_"(811.9,RIEN,.PACKLIST)"
. D @ROUTINE
Q
;
;==========================================
EXISTS(FILENUM,IEN,PACKLIST) ;If the entry already exists remove it
;and keep only the higher entry.
I '$D(PACKLIST(FILENUM,"IEN",IEN)) Q
N NUM
S NUM=PACKLIST(FILENUM,"IEN",IEN)
K PACKLIST(FILENUM,NUM)
Q
;
;==========================================
GEDSUB(EDUIEN,NSUB,LIST) ;Build the recursive list of education topic
;subtopics.
;DBIA #3085
N IND,SUBIEN
S IND=0
F S IND=+$O(^AUTTEDT(EDUIEN,10,IND)) Q:IND=0 D
. S NSUB=NSUB+1
. S SUBIEN=$P(^AUTTEDT(EDUIEN,10,IND,0),U,1)
. S LIST(NSUB)=SUBIEN
. D GEDSUB(SUBIEN,.NSUB,.LIST)
Q
;
;==========================================
GETFNUM(GBL) ;Return the file number for a global.
S GBL="^"_GBL_"0)"
Q +$P(@GBL,U,2)
;
;==========================================
GETSRTN(FILENUM) ;Return the save routine according to the file number.
I FILENUM=50 Q "SGEN^PXRMEXPS"
I FILENUM=50.6 Q "SGEN^PXRMEXPS"
I FILENUM=50.605 Q "SGEN^PXRMEXPS"
I FILENUM=60 Q "SLT^PXRMEXPS"
I FILENUM=71 Q "SGEN^PXRMEXPS"
I FILENUM=80 Q "NOSAVE^PXRMEXPS"
I FILENUM=80.1 Q "NOSAVE^PXRMEXPS"
I FILENUM=81 Q "NOSAVE^PXRMEXPS"
I FILENUM=101.41 Q "SODIALOG^PXRMEXPS"
I FILENUM=101.43 Q "SGEN^PXRMEXPS"
I FILENUM=120.51 Q "SGEN^PXRMEXPS"
I FILENUM=142 Q "SHST^PXRMEXPS"
I FILENUM=142.1 Q "SGEN^PXRMEXPS"
I FILENUM=142.5 Q "SHSO^PXRMEXPS"
I FILENUM=601.71 Q "SGEN^PXRMEXPS"
I FILENUM=790.404 Q "SGEN^PXRMEXPS"
I FILENUM=801 Q "SROC^PXRMEXPS"
I FILENUM=801.1 Q "SRULE^PXRMEXPS"
I FILENUM=801.41 Q "SDIALOG^PXRMEXPS"
I FILENUM=810.2 Q "SEDEF^PXRMEXPS"
I FILENUM=810.4 Q "SLR^PXRMEXPS"
I FILENUM=810.7 Q "SRECR^PXRMEXPS"
I FILENUM=810.8 Q "SRCG^PXRMEXPS"
I FILENUM=810.9 Q "SLL^PXRMEXPS"
I FILENUM=811.2 Q "SGENR^PXRMEXPS"
I FILENUM=811.4 Q "SCF^PXRMEXPS"
I FILENUM=811.5 Q "SRT^PXRMEXPS"
I FILENUM=811.6 Q "SGEN^PXRMEXPS"
I FILENUM=811.9 Q "SDEF^PXRMEXPS"
I FILENUM=8925.1 Q "STIUOBJ^PXRMEXPS"
I FILENUM=8927.1 Q "STIUTEMP^PXRMEXPS"
I FILENUM=9999999.09 Q "SED^PXRMEXPS"
I FILENUM=9999999.14 Q "SGEN^PXRMEXPS"
I FILENUM=9999999.15 Q "SGEN^PXRMEXPS"
I FILENUM=9999999.28 Q "SGEN^PXRMEXPS"
I FILENUM=9999999.64 Q "SHF^PXRMEXPS"
;IHS/MSC/MGH added files not in VA reminders
I FILENUM=9001002.95 Q "SGEN^PXRMEXPS"
I FILENUM=9999999.07 Q "SGEN^PXRMEXPS"
I FILENUM=9001017 Q "SGEN^PXRMEXPS"
I FILENUM=9001020 Q "SGEN^PXRMEXPS"
Q "NORTN^PXRMEXPS"
;
;==========================================
NORTN(FILENUM,IEN,PACKLIST) ;Don't have a routine for this file number.
S NF=+$O(PACKLIST(FILENUM,"IEN"),-1)+1
S PACKLIST(FILENUM,NF)=IEN
S PACKLIST(FILENUM,"IEN",IEN)=NF
S PACKLIST(FILENUM,"ERROR",IEN)="No packing routine for file number "_FILENUM_"."
Q
;
;==========================================
NOSAVE(FILENUM,IEN,PACKLIST) ;Don't do anything for this file number.
Q
;
;==========================================
SCF(FILENUM,IEN,PACKLIST) ;Reminder computed findings.
N CFRTN
;Add the computed finding file entry.
D SGENR(FILENUM,IEN,.PACKLIST)
S CFRTN=$P(^PXRMD(811.4,IEN,0),U,2)
;Add the routine; mark routines with file number 0.
D SGEN(0,CFRTN,.PACKLIST)
Q
;
;==========================================
SDEF(FILENUM,RIEN,PACKLIST) ;Reminder definitions.
N DIALOG,ENODE,EO,FINDING,FINUM,FNUM,GBL,IEN,NF,ROUTINE,SPON
D SGENR(FILENUM,RIEN,.PACKLIST)
;Process the finding multiple.
S FINUM=0
F S FINUM=+$O(^PXD(811.9,RIEN,20,FINUM)) Q:FINUM=0 D
. S FINDING=$P(^PXD(811.9,RIEN,20,FINUM,0),U,1)
. S IEN=$P(FINDING,";",1)
. S GBL=$P(FINDING,";",2)
. S FNUM=$$GETFNUM(GBL)
. I FNUM=811.4 D CHKCF("^PXD(811.9)",RIEN,GBL,.PACKLIST)
. S ROUTINE=$$GETSRTN(FNUM)_"(FNUM,IEN,.PACKLIST)"
. D @ROUTINE
;Dialog
S DIALOG=+$G(^PXD(811.9,RIEN,51))
I DIALOG>0,'$D(PACKLIST(801.41,"IEN",DIALOG)) D SDIALOG(801.41,DIALOG,.PACKLIST)
Q
;
;==========================================
SDIALOG(FILENUM,DIEN,PACKLIST) ;Reminder dialogs.
I DIEN'>0 Q
N IEN,IND,FI,FNUM,GBL,MHT,OI,OLIST,REG,ROUTINE,TEMP,TERM,TLIST
D SGENR(FILENUM,DIEN,.PACKLIST)
;Check for a finding item.
S TEMP=$G(^PXRMD(801.41,DIEN,1))
S FI=$P(TEMP,U,5)
I FI'="" D
. S IEN=$P(FI,";",1)
. S GBL=$P(FI,";",2)
. S FNUM=$$GETFNUM(GBL)
. S ROUTINE=$$GETSRTN(FNUM)_"(FNUM,IEN,.PACKLIST)"
. D @ROUTINE
;Check for an orderable item.
S OI=$P(TEMP,U,7)
I OI'="" D
. S ROUTINE=$$GETSRTN(101.43)_"(101.43,OI,.PACKLIST)"
. D @ROUTINE
;Check for additional findings.
S IND=0
F S IND=+$O(^PXRMD(801.41,DIEN,3,IND)) Q:IND=0 D
. S FI=$P(^PXRMD(801.41,DIEN,3,IND,0),U,1)
. S IEN=$P(FI,";",1)
. S GBL=$P(FI,";",2)
. S FNUM=$$GETFNUM(GBL)
. S ROUTINE=$$GETSRTN(FNUM)_"(FNUM,IEN,.PACKLIST)"
. D @ROUTINE
;Check word processing fields for TIU Object and Template Fields
D TIUSRCH^PXRMEXU1("^PXRMD(801.41,",DIEN,25,.OLIST,.TLIST)
I $D(OLIST)>0 D
. S ROUTINE=$$GETSRTN(8925.1)_"(8925.1,.OLIST,.PACKLIST)"
. D @ROUTINE K OLIST
I $D(TLIST)>0 D
. S ROUTINE=$$GETSRTN(8927.1)_"(8927.1,.TLIST,.PACKLIST)"
. D @ROUTINE K TLIST
D TIUSRCH^PXRMEXU1("^PXRMD(801.41,",DIEN,35,.OLIST,.TLIST)
I $D(OLIST)>0 D
. S ROUTINE=$$GETSRTN(8925.1)_"(8925.1,.OLIST,.PACKLIST)"
. D @ROUTINE K OLIST
I $D(TLIST)>0 D
. S ROUTINE=$$GETSRTN(8927.1)_"(8927.1,.TLIST,.PACKLIST)"
. D @ROUTINE K TLIST
;Check the components multiple for elements.
I $D(^PXRMD(801.41,DIEN,10)) D
. S ROUTINE=$$GETSRTN(801.41)_"(801.41,IEN,.PACKLIST)"
. S IND=0
. F S IND=+$O(^PXRMD(801.41,DIEN,10,IND)) Q:IND=0 D
.. S IEN=$P(^PXRMD(801.41,DIEN,10,IND,0),U,2)
.. D @ROUTINE
;Check for a term and a replacement element/group.
S TEMP=$G(^PXRMD(801.41,DIEN,49))
S TERM=$P(TEMP,U,1)
I TERM'="" D
. S ROUTINE=$$GETSRTN(811.5)_"(811.5,TERM,.PACKLIST)"
. D @ROUTINE
S REG=$P(TEMP,U,3)
I REG'="" D
. S ROUTINE=$$GETSRTN(801.41)_"(801.41,REG,.PACKLIST)"
. D @ROUTINE
;Check for a mental health test.
S MHT=$P($G(^PXRMD(801.41,DIEN,50)),U,1)
I MHT'="" D
. S ROUTINE=$$GETSRTN(601.71)_"(601.71,MHT,.PACKLIST)"
. D @ROUTINE
;Check for result groups.
I $D(^PXRMD(801.41,DIEN,51)) D
. S ROUTINE=$$GETSRTN(801.41)_"(801.41,IEN,.PACKLIST)"
. S IND=0
. F S IND=+$O(^PXRMD(801.41,DIEN,51,IND)) Q:IND=0 D
.. S IEN=$P(^PXRMD(801.41,DIEN,51,IND,0),U,1)
.. D @ROUTINE
Q
;
;==========================================
SED(FILENUM,IEN,PACKLIST) ;Education topics.
N IND,NF,NSUB,SUBLIST
D EXISTS(FILENUM,IEN,.PACKLIST)
D ADD(FILENUM,IEN,.PACKLIST,.NF)
S NSUB=0
;Get all the subtopics.
D GEDSUB(IEN,.NSUB,.SUBLIST)
F IND=1:1:NSUB D
. D EXISTS(FILENUM,SUBLIST(IND),.PACKLIST)
. S NF=NF+1
. S PACKLIST(FILENUM,NF)=SUBLIST(IND)
. S PACKLIST(FILENUM,"IEN",SUBLIST(IND))=NF
Q
;
;==========================================
SEDEF(FILENUM,IEN,PACKLIST) ;Reminder extract definitions.
N CR,CRRTN,IND,JND,LRRTN,LRS,RDEF,RDEFRTN,TEMP
D SGEN(FILENUM,IEN,.PACKLIST)
;Initialize the save routines.
S LRRTN=$$GETSRTN(810.4)_"(810.4,LRS,.PACKLIST)"
S CRRTN=$$GETSRTN(810.7)_"(810.7,CR,.PACKLIST)"
S RDEFRTN=$$GETSRTN(811.9)_"(811.9,RDEF,.PACKLIST)"
;Go through the extract sequence.
S IND=0
F S IND=+$O(^PXRM(810.2,IEN,10,IND)) Q:IND=0 D
. S LRS=$P(^PXRM(810.2,IEN,10,IND,0),U,2)
. D @LRRTN
.;Go through the reminders and counting rules.
. S JND=0
. F S JND=+$O(^PXRM(810.2,IEN,10,IND,10,JND)) Q:JND=0 D
.. S TEMP=^PXRM(810.2,IEN,10,IND,10,JND,0)
.. S RDEF=$P(TEMP,U,2)
.. I RDEF'="" D @RDEFRTN
.. S CR=$P(TEMP,U,3)
.. I CR'="" D @CRRTN
Q
;
;==========================================
SGEN(FILENUM,IEN,PACKLIST) ;General save routine, used for everything that
;does not require special handling.
N NF
D EXISTS(FILENUM,IEN,.PACKLIST)
D ADD(FILENUM,IEN,.PACKLIST,.NF)
Q
;
;==========================================
SGENR(FILENUM,IEN,PACKLIST) ;General reminder global save routine, used for
;reminder globals that do not require special handling.
N SPON
D SGEN(FILENUM,IEN,.PACKLIST)
S SPON=+$$GET1^DIQ(FILENUM,IEN,101,"I")
I SPON>0 D SGEN(811.6,SPON,.PACKLIST)
Q
;
;==========================================
SHF(FILENUM,IEN,PACKLIST) ;Health factors.
N CAT,HF,NF
;All health factor references covered by DBIA #3083.
;If the health factor is a category then it has to be coming from
;a health summary so include all the health factors in the category.
I $P(^AUTTHF(IEN,0),U,10)="C" D
. S CAT=1,HF=0
. F S HF=$O(^AUTTHF("AC",IEN,HF)) Q:HF'>0 D
.. D EXISTS(FILENUM,HF,.PACKLIST)
.. D ADD(FILENUM,HF,.PACKLIST,.NF)
D EXISTS(FILENUM,IEN,.PACKLIST)
D ADD(FILENUM,IEN,.PACKLIST,.NF)
I $G(CAT) Q
;For a regular health factor make sure the category is on the list.
S CAT=$P(^AUTTHF(IEN,0),U,3)
D EXISTS(FILENUM,CAT,.PACKLIST)
S NF=NF+1
S PACKLIST(FILENUM,NF)=CAT
S PACKLIST(FILENUM,"IEN",CAT)=NF
Q
;
;==========================================
SHSO(FILENUM,IEN,PACKLIST) ;Health summary object.
N HST
D SGEN(FILENUM,IEN,.PACKLIST)
S HST=$P($G(^GMT(142.5,IEN,0)),U,3)
S ROUTINE=$$GETSRTN(142)_"(142,HST,.PACKLIST)"
D @ROUTINE
Q
;
;==========================================
SHST(FILENUM,IEN,PACKLIST) ;Health Summary Type
N CNT,FNUM,GBL,HSC,ITEM,NODE,ROUTINE,SEL
D SGEN(FILENUM,IEN,.PACKLIST)
S CNT=0 F S CNT=$O(^GMT(142,IEN,1,CNT)) Q:CNT'>0 D
.S HSC=$P($G(^GMT(142,IEN,1,CNT,0)),U,2)
.S ROUTINE=$$GETSRTN(142.1)_"(142.1,HSC,.PACKLIST)"
.D @ROUTINE
.;Loop through selection item, variable pointer
.S SEL=0 F S SEL=$O(^GMT(142,IEN,1,CNT,1,SEL)) Q:SEL'>0 D
..S NODE=$P($G(^GMT(142,IEN,1,CNT,1,SEL,0)),U)
..I NODE'="" D
...S ITEM=$P(NODE,";",1)
...S GBL=$P(NODE,";",2)
...S FNUM=$$GETFNUM(GBL)
...S ROUTINE=$$GETSRTN(FNUM)_"(FNUM,ITEM,.PACKLIST)"
...I ROUTINE="NOROUTINE" Q
...D @ROUTINE
Q
;
;==========================================
SLL(FILENUM,IEN,PACKLIST) ;Reminder location lists.
N CSTEXL,IND,ROUTINE
D SGEN(FILENUM,IEN,.PACKLIST)
;If CREDIT STOPS TO EXCLUDE (LIST) has been used put it on the packing
;list.
S IND=0
F S IND=+$O(^PXRMD(810.9,IEN,40.7,IND)) Q:IND=0 D
. S CSTEXL=$G(^PXRMD(810.9,IEN,40.7,IND,2))
. I CSTEXL="" Q
. S ROUTINE=$$GETSRTN(810.9)_"(810.9,CSTEXL,.PACKLIST)"
. D @ROUTINE
;Save information about hospital locations which are non-transportable.
I $D(^PXRMD(810.9,IEN,44))>1 D NTHLOC^PXRMEXFI(IEN,"LOCATION LIST")
Q
;
;==========================================
SLR(FILENUM,IEN,PACKLIST) ;Reminder list rules.
N IND,LR,RDEF,RTERM,ROUTINE,TEMP
D SGEN(FILENUM,IEN,.PACKLIST)
S TEMP=^PXRM(810.4,IEN,0)
S RTERM=$P(TEMP,U,7)
I RTERM'="" D
. S ROUTINE=$$GETSRTN(811.5)_"(811.5,RTERM,.PACKLIST)"
. D @ROUTINE
S RDEF=$P(TEMP,U,10)
I RDEF'="" D
. S ROUTINE=$$GETSRTN(811.9)_"(811.9,RDEF,.PACKLIST)"
. D @ROUTINE
;If there is a sequence save the list rules.
I '$D(^PXRM(810.4,IEN,30)) Q
S ROUTINE=$$GETSRTN(810.4)_"(810.4,LR,.PACKLIST)"
S IND=0
F S IND=+$O(^PXRM(810.4,IEN,30,IND)) Q:IND=0 D
. S LR=$P(^PXRM(810.4,IEN,30,IND,0),U,2)
. D @ROUTINE
Q
;
;==========================================
SLT(FILENUM,IEN,PACKLIST) ;Lab tests
I +IEN'=IEN S IEN=$P(IEN,";",3)
D SGEN(FILENUM,IEN,.PACKLIST)
Q
;
;==========================================
SODIALOG(FILENUM,IEN,PACKLIST) ;Order dialogs.
D SGEN(FILENUM,IEN,.PACKLIST)
;DBIA 5446
D EN^ORORDDSC(IEN,"ORDER DIALOG")
Q
;
;==========================================
SRCG(FILENUM,IEN,PACKLIST) ;Reminder counting groups.
N IND,ROUTINE,TIEN
D SGEN(FILENUM,IEN,.PACKLIST)
;Put terms on the pack list.
S ROUTINE=$$GETSRTN(811.5)_"(811.5,TIEN,.PACKLIST)"
S IND=0
F S IND=+$O(^PXRM(810.8,IEN,10,IND)) Q:IND=0 D
. S TIEN=$P(^PXRM(810.8,IEN,10,IND,0),U,2)
. D @ROUTINE
Q
;
;==========================================
SRECR(FILENUM,IEN,PACKLIST) ;Reminder extract counting rule.
N CGIEN,IND,ROUTINE,TIEN
D SGEN(FILENUM,IEN,.PACKLIST)
;Put counting groups on the pack list.
S ROUTINE=$$GETSRTN(810.8)_"(810.8,CGIEN,.PACKLIST)"
S IND=0
F S IND=+$O(^PXRM(810.7,IEN,10,IND)) Q:IND=0 D
. S CGIEN=$P(^PXRM(810.7,IEN,10,IND,0),U,2)
. D @ROUTINE
Q
;
;==========================================
SRT(FILENUM,TIEN,PACKLIST) ;Reminder terms.
N FNUM,GBL,IEN,NF,ROUTINE,SPON
N ITEM,NUM,RIEN
D EXISTS(FILENUM,TIEN,.PACKLIST)
D ADD(FILENUM,TIEN,.PACKLIST,.NF)
;Process the finding multiple.
S GBL=""
F S GBL=$O(^PXRMD(811.5,TIEN,20,"E",GBL)) Q:GBL="" D
. S FNUM=$$GETFNUM(GBL)
. I FNUM=811.4 D CHKCF("^PXRMD(811.5)",TIEN,GBL,.PACKLIST)
. S ROUTINE=$$GETSRTN(FNUM)_"(FNUM,IEN,.PACKLIST)"
. S IEN=""
. F S IEN=$O(^PXRMD(811.5,TIEN,20,"E",GBL,IEN)) Q:IEN="" D @ROUTINE
;Sponsor
S SPON=+$P(^PXRMD(811.5,TIEN,100),U,2)
I SPON>0 D SGEN(811.6,SPON,.PACKLIST)
Q
;
;==========================================
SROC(FILENUM,ROCIEN,PACKLIST) ;Reminder Order Checks.
;packed order check structure up
D SROC^BPXRMEX1(FILENUM,ROCIEN,PACKLIST)
Q
;
;==========================================
SRULE(FILENUM,RULEIEN,PACKLIST) ;Reminder Order Check Rules.
;packed order check structure up
D SRULE^BPXRMEX1(FILENUM,RULEIEN,PACKLIST)
Q
;
;==========================================
STIUOBJ(FILENUM,OLIST,PACKLIST) ;
N ARY,CNT,HSO,IEN,NAME,ROUTINE,TEMP
S CNT=0 F S CNT=$O(OLIST(CNT)) Q:CNT'>0 D
. S NAME=OLIST(CNT)
. ;DBIA 5447
. S IEN=$$OBJBYNAM^TIUCHECK(.ARY,NAME) I IEN=-1 Q
.;Do not ship non TIU/HS Objects
. I $G(ARY(IEN,9))'["S X=$$TIU^GMTSOBJ(" D Q
.. D TIU^PXRMEXU5(IEN,.ARY,"TIU OBJECT")
.. D SGEN(FILENUM,IEN,.PACKLIST)
. D SGEN(FILENUM,IEN,.PACKLIST)
. S TEMP=$P($G(ARY(IEN,9)),",",2)
. S HSO=$P(TEMP,")")
. S ROUTINE=$$GETSRTN(142.5)_"(142.5,.HSO,.PACKLIST)"
. D @ROUTINE
Q
;
;==========================================
STIUTEMP(FILENUM,TLIST,PACKLIST) ;
N CNT,IEN,NAME
S CNT=0 F S CNT=$O(TLIST(CNT)) Q:CNT'>0 D
.S NAME=TLIST(CNT)
.S IEN=$O(^TIU(8927.1,"B",NAME,"")) Q:IEN'>0
.D SGEN(FILENUM,IEN,.PACKLIST)
Q
;
PXRMEXPS ; SLC/PKR - Packing save routines. ;13-Aug-2015 12:06;du
+1 ;;2.0;CLINICAL REMINDERS;**12,16,18,22,24,26,1005**;Feb 04, 2005;Build 23
+2 ;==========================================
ADD(FILENUM,IEN,PACKLIST,NF) ;
+1 SET NF=+$ORDER(PACKLIST(FILENUM,"IEN"),-1)+1
+2 SET PACKLIST(FILENUM,NF)=IEN
+3 SET PACKLIST(FILENUM,"IEN",IEN)=NF
+4 QUIT
+5 ;
+6 ;==========================================
CHKCF(ROOT,TOPIEN,GBL,PACKLIST) ;
+1 NEW IEN,NAME,NUM,PARM,RIEN,ROUTINE
+2 SET IEN=""
+3 FOR
SET IEN=$ORDER(@ROOT@(TOPIEN,20,"E",GBL,IEN))
IF IEN=""
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^PXRMD(811.4,IEN,0)),U,1)'="VA-REMINDER DEFINITION"
QUIT
+5 SET NUM=$ORDER(@ROOT@(TOPIEN,20,"E",GBL,IEN,""))
IF NUM'>0
QUIT
+6 SET PARM=$PIECE($GET(@ROOT@(TOPIEN,20,NUM,15)),U,1)
+7 SET NAME=$PIECE(PARM,U,1)
+8 SET RIEN=$ORDER(^PXD(811.9,"B",NAME,""))
IF RIEN'>0
QUIT
+9 SET ROUTINE=$$GETSRTN(811.9)_"(811.9,RIEN,.PACKLIST)"
+10 DO @ROUTINE
End DoDot:1
+11 QUIT
+12 ;
+13 ;==========================================
EXISTS(FILENUM,IEN,PACKLIST) ;If the entry already exists remove it
+1 ;and keep only the higher entry.
+2 IF '$DATA(PACKLIST(FILENUM,"IEN",IEN))
QUIT
+3 NEW NUM
+4 SET NUM=PACKLIST(FILENUM,"IEN",IEN)
+5 KILL PACKLIST(FILENUM,NUM)
+6 QUIT
+7 ;
+8 ;==========================================
GEDSUB(EDUIEN,NSUB,LIST) ;Build the recursive list of education topic
+1 ;subtopics.
+2 ;DBIA #3085
+3 NEW IND,SUBIEN
+4 SET IND=0
+5 FOR
SET IND=+$ORDER(^AUTTEDT(EDUIEN,10,IND))
IF IND=0
QUIT
Begin DoDot:1
+6 SET NSUB=NSUB+1
+7 SET SUBIEN=$PIECE(^AUTTEDT(EDUIEN,10,IND,0),U,1)
+8 SET LIST(NSUB)=SUBIEN
+9 DO GEDSUB(SUBIEN,.NSUB,.LIST)
End DoDot:1
+10 QUIT
+11 ;
+12 ;==========================================
GETFNUM(GBL) ;Return the file number for a global.
+1 SET GBL="^"_GBL_"0)"
+2 QUIT +$PIECE(@GBL,U,2)
+3 ;
+4 ;==========================================
GETSRTN(FILENUM) ;Return the save routine according to the file number.
+1 IF FILENUM=50
QUIT "SGEN^PXRMEXPS"
+2 IF FILENUM=50.6
QUIT "SGEN^PXRMEXPS"
+3 IF FILENUM=50.605
QUIT "SGEN^PXRMEXPS"
+4 IF FILENUM=60
QUIT "SLT^PXRMEXPS"
+5 IF FILENUM=71
QUIT "SGEN^PXRMEXPS"
+6 IF FILENUM=80
QUIT "NOSAVE^PXRMEXPS"
+7 IF FILENUM=80.1
QUIT "NOSAVE^PXRMEXPS"
+8 IF FILENUM=81
QUIT "NOSAVE^PXRMEXPS"
+9 IF FILENUM=101.41
QUIT "SODIALOG^PXRMEXPS"
+10 IF FILENUM=101.43
QUIT "SGEN^PXRMEXPS"
+11 IF FILENUM=120.51
QUIT "SGEN^PXRMEXPS"
+12 IF FILENUM=142
QUIT "SHST^PXRMEXPS"
+13 IF FILENUM=142.1
QUIT "SGEN^PXRMEXPS"
+14 IF FILENUM=142.5
QUIT "SHSO^PXRMEXPS"
+15 IF FILENUM=601.71
QUIT "SGEN^PXRMEXPS"
+16 IF FILENUM=790.404
QUIT "SGEN^PXRMEXPS"
+17 IF FILENUM=801
QUIT "SROC^PXRMEXPS"
+18 IF FILENUM=801.1
QUIT "SRULE^PXRMEXPS"
+19 IF FILENUM=801.41
QUIT "SDIALOG^PXRMEXPS"
+20 IF FILENUM=810.2
QUIT "SEDEF^PXRMEXPS"
+21 IF FILENUM=810.4
QUIT "SLR^PXRMEXPS"
+22 IF FILENUM=810.7
QUIT "SRECR^PXRMEXPS"
+23 IF FILENUM=810.8
QUIT "SRCG^PXRMEXPS"
+24 IF FILENUM=810.9
QUIT "SLL^PXRMEXPS"
+25 IF FILENUM=811.2
QUIT "SGENR^PXRMEXPS"
+26 IF FILENUM=811.4
QUIT "SCF^PXRMEXPS"
+27 IF FILENUM=811.5
QUIT "SRT^PXRMEXPS"
+28 IF FILENUM=811.6
QUIT "SGEN^PXRMEXPS"
+29 IF FILENUM=811.9
QUIT "SDEF^PXRMEXPS"
+30 IF FILENUM=8925.1
QUIT "STIUOBJ^PXRMEXPS"
+31 IF FILENUM=8927.1
QUIT "STIUTEMP^PXRMEXPS"
+32 IF FILENUM=9999999.09
QUIT "SED^PXRMEXPS"
+33 IF FILENUM=9999999.14
QUIT "SGEN^PXRMEXPS"
+34 IF FILENUM=9999999.15
QUIT "SGEN^PXRMEXPS"
+35 IF FILENUM=9999999.28
QUIT "SGEN^PXRMEXPS"
+36 IF FILENUM=9999999.64
QUIT "SHF^PXRMEXPS"
+37 ;IHS/MSC/MGH added files not in VA reminders
+38 IF FILENUM=9001002.95
QUIT "SGEN^PXRMEXPS"
+39 IF FILENUM=9999999.07
QUIT "SGEN^PXRMEXPS"
+40 IF FILENUM=9001017
QUIT "SGEN^PXRMEXPS"
+41 IF FILENUM=9001020
QUIT "SGEN^PXRMEXPS"
+42 QUIT "NORTN^PXRMEXPS"
+43 ;
+44 ;==========================================
NORTN(FILENUM,IEN,PACKLIST) ;Don't have a routine for this file number.
+1 SET NF=+$ORDER(PACKLIST(FILENUM,"IEN"),-1)+1
+2 SET PACKLIST(FILENUM,NF)=IEN
+3 SET PACKLIST(FILENUM,"IEN",IEN)=NF
+4 SET PACKLIST(FILENUM,"ERROR",IEN)="No packing routine for file number "_FILENUM_"."
+5 QUIT
+6 ;
+7 ;==========================================
NOSAVE(FILENUM,IEN,PACKLIST) ;Don't do anything for this file number.
+1 QUIT
+2 ;
+3 ;==========================================
SCF(FILENUM,IEN,PACKLIST) ;Reminder computed findings.
+1 NEW CFRTN
+2 ;Add the computed finding file entry.
+3 DO SGENR(FILENUM,IEN,.PACKLIST)
+4 SET CFRTN=$PIECE(^PXRMD(811.4,IEN,0),U,2)
+5 ;Add the routine; mark routines with file number 0.
+6 DO SGEN(0,CFRTN,.PACKLIST)
+7 QUIT
+8 ;
+9 ;==========================================
SDEF(FILENUM,RIEN,PACKLIST) ;Reminder definitions.
+1 NEW DIALOG,ENODE,EO,FINDING,FINUM,FNUM,GBL,IEN,NF,ROUTINE,SPON
+2 DO SGENR(FILENUM,RIEN,.PACKLIST)
+3 ;Process the finding multiple.
+4 SET FINUM=0
+5 FOR
SET FINUM=+$ORDER(^PXD(811.9,RIEN,20,FINUM))
IF FINUM=0
QUIT
Begin DoDot:1
+6 SET FINDING=$PIECE(^PXD(811.9,RIEN,20,FINUM,0),U,1)
+7 SET IEN=$PIECE(FINDING,";",1)
+8 SET GBL=$PIECE(FINDING,";",2)
+9 SET FNUM=$$GETFNUM(GBL)
+10 IF FNUM=811.4
DO CHKCF("^PXD(811.9)",RIEN,GBL,.PACKLIST)
+11 SET ROUTINE=$$GETSRTN(FNUM)_"(FNUM,IEN,.PACKLIST)"
+12 DO @ROUTINE
End DoDot:1
+13 ;Dialog
+14 SET DIALOG=+$GET(^PXD(811.9,RIEN,51))
+15 IF DIALOG>0
IF '$DATA(PACKLIST(801.41,"IEN",DIALOG))
DO SDIALOG(801.41,DIALOG,.PACKLIST)
+16 QUIT
+17 ;
+18 ;==========================================
SDIALOG(FILENUM,DIEN,PACKLIST) ;Reminder dialogs.
+1 IF DIEN'>0
QUIT
+2 NEW IEN,IND,FI,FNUM,GBL,MHT,OI,OLIST,REG,ROUTINE,TEMP,TERM,TLIST
+3 DO SGENR(FILENUM,DIEN,.PACKLIST)
+4 ;Check for a finding item.
+5 SET TEMP=$GET(^PXRMD(801.41,DIEN,1))
+6 SET FI=$PIECE(TEMP,U,5)
+7 IF FI'=""
Begin DoDot:1
+8 SET IEN=$PIECE(FI,";",1)
+9 SET GBL=$PIECE(FI,";",2)
+10 SET FNUM=$$GETFNUM(GBL)
+11 SET ROUTINE=$$GETSRTN(FNUM)_"(FNUM,IEN,.PACKLIST)"
+12 DO @ROUTINE
End DoDot:1
+13 ;Check for an orderable item.
+14 SET OI=$PIECE(TEMP,U,7)
+15 IF OI'=""
Begin DoDot:1
+16 SET ROUTINE=$$GETSRTN(101.43)_"(101.43,OI,.PACKLIST)"
+17 DO @ROUTINE
End DoDot:1
+18 ;Check for additional findings.
+19 SET IND=0
+20 FOR
SET IND=+$ORDER(^PXRMD(801.41,DIEN,3,IND))
IF IND=0
QUIT
Begin DoDot:1
+21 SET FI=$PIECE(^PXRMD(801.41,DIEN,3,IND,0),U,1)
+22 SET IEN=$PIECE(FI,";",1)
+23 SET GBL=$PIECE(FI,";",2)
+24 SET FNUM=$$GETFNUM(GBL)
+25 SET ROUTINE=$$GETSRTN(FNUM)_"(FNUM,IEN,.PACKLIST)"
+26 DO @ROUTINE
End DoDot:1
+27 ;Check word processing fields for TIU Object and Template Fields
+28 DO TIUSRCH^PXRMEXU1("^PXRMD(801.41,",DIEN,25,.OLIST,.TLIST)
+29 IF $DATA(OLIST)>0
Begin DoDot:1
+30 SET ROUTINE=$$GETSRTN(8925.1)_"(8925.1,.OLIST,.PACKLIST)"
+31 DO @ROUTINE
KILL OLIST
End DoDot:1
+32 IF $DATA(TLIST)>0
Begin DoDot:1
+33 SET ROUTINE=$$GETSRTN(8927.1)_"(8927.1,.TLIST,.PACKLIST)"
+34 DO @ROUTINE
KILL TLIST
End DoDot:1
+35 DO TIUSRCH^PXRMEXU1("^PXRMD(801.41,",DIEN,35,.OLIST,.TLIST)
+36 IF $DATA(OLIST)>0
Begin DoDot:1
+37 SET ROUTINE=$$GETSRTN(8925.1)_"(8925.1,.OLIST,.PACKLIST)"
+38 DO @ROUTINE
KILL OLIST
End DoDot:1
+39 IF $DATA(TLIST)>0
Begin DoDot:1
+40 SET ROUTINE=$$GETSRTN(8927.1)_"(8927.1,.TLIST,.PACKLIST)"
+41 DO @ROUTINE
KILL TLIST
End DoDot:1
+42 ;Check the components multiple for elements.
+43 IF $DATA(^PXRMD(801.41,DIEN,10))
Begin DoDot:1
+44 SET ROUTINE=$$GETSRTN(801.41)_"(801.41,IEN,.PACKLIST)"
+45 SET IND=0
+46 FOR
SET IND=+$ORDER(^PXRMD(801.41,DIEN,10,IND))
IF IND=0
QUIT
Begin DoDot:2
+47 SET IEN=$PIECE(^PXRMD(801.41,DIEN,10,IND,0),U,2)
+48 DO @ROUTINE
End DoDot:2
End DoDot:1
+49 ;Check for a term and a replacement element/group.
+50 SET TEMP=$GET(^PXRMD(801.41,DIEN,49))
+51 SET TERM=$PIECE(TEMP,U,1)
+52 IF TERM'=""
Begin DoDot:1
+53 SET ROUTINE=$$GETSRTN(811.5)_"(811.5,TERM,.PACKLIST)"
+54 DO @ROUTINE
End DoDot:1
+55 SET REG=$PIECE(TEMP,U,3)
+56 IF REG'=""
Begin DoDot:1
+57 SET ROUTINE=$$GETSRTN(801.41)_"(801.41,REG,.PACKLIST)"
+58 DO @ROUTINE
End DoDot:1
+59 ;Check for a mental health test.
+60 SET MHT=$PIECE($GET(^PXRMD(801.41,DIEN,50)),U,1)
+61 IF MHT'=""
Begin DoDot:1
+62 SET ROUTINE=$$GETSRTN(601.71)_"(601.71,MHT,.PACKLIST)"
+63 DO @ROUTINE
End DoDot:1
+64 ;Check for result groups.
+65 IF $DATA(^PXRMD(801.41,DIEN,51))
Begin DoDot:1
+66 SET ROUTINE=$$GETSRTN(801.41)_"(801.41,IEN,.PACKLIST)"
+67 SET IND=0
+68 FOR
SET IND=+$ORDER(^PXRMD(801.41,DIEN,51,IND))
IF IND=0
QUIT
Begin DoDot:2
+69 SET IEN=$PIECE(^PXRMD(801.41,DIEN,51,IND,0),U,1)
+70 DO @ROUTINE
End DoDot:2
End DoDot:1
+71 QUIT
+72 ;
+73 ;==========================================
SED(FILENUM,IEN,PACKLIST) ;Education topics.
+1 NEW IND,NF,NSUB,SUBLIST
+2 DO EXISTS(FILENUM,IEN,.PACKLIST)
+3 DO ADD(FILENUM,IEN,.PACKLIST,.NF)
+4 SET NSUB=0
+5 ;Get all the subtopics.
+6 DO GEDSUB(IEN,.NSUB,.SUBLIST)
+7 FOR IND=1:1:NSUB
Begin DoDot:1
+8 DO EXISTS(FILENUM,SUBLIST(IND),.PACKLIST)
+9 SET NF=NF+1
+10 SET PACKLIST(FILENUM,NF)=SUBLIST(IND)
+11 SET PACKLIST(FILENUM,"IEN",SUBLIST(IND))=NF
End DoDot:1
+12 QUIT
+13 ;
+14 ;==========================================
SEDEF(FILENUM,IEN,PACKLIST) ;Reminder extract definitions.
+1 NEW CR,CRRTN,IND,JND,LRRTN,LRS,RDEF,RDEFRTN,TEMP
+2 DO SGEN(FILENUM,IEN,.PACKLIST)
+3 ;Initialize the save routines.
+4 SET LRRTN=$$GETSRTN(810.4)_"(810.4,LRS,.PACKLIST)"
+5 SET CRRTN=$$GETSRTN(810.7)_"(810.7,CR,.PACKLIST)"
+6 SET RDEFRTN=$$GETSRTN(811.9)_"(811.9,RDEF,.PACKLIST)"
+7 ;Go through the extract sequence.
+8 SET IND=0
+9 FOR
SET IND=+$ORDER(^PXRM(810.2,IEN,10,IND))
IF IND=0
QUIT
Begin DoDot:1
+10 SET LRS=$PIECE(^PXRM(810.2,IEN,10,IND,0),U,2)
+11 DO @LRRTN
+12 ;Go through the reminders and counting rules.
+13 SET JND=0
+14 FOR
SET JND=+$ORDER(^PXRM(810.2,IEN,10,IND,10,JND))
IF JND=0
QUIT
Begin DoDot:2
+15 SET TEMP=^PXRM(810.2,IEN,10,IND,10,JND,0)
+16 SET RDEF=$PIECE(TEMP,U,2)
+17 IF RDEF'=""
DO @RDEFRTN
+18 SET CR=$PIECE(TEMP,U,3)
+19 IF CR'=""
DO @CRRTN
End DoDot:2
End DoDot:1
+20 QUIT
+21 ;
+22 ;==========================================
SGEN(FILENUM,IEN,PACKLIST) ;General save routine, used for everything that
+1 ;does not require special handling.
+2 NEW NF
+3 DO EXISTS(FILENUM,IEN,.PACKLIST)
+4 DO ADD(FILENUM,IEN,.PACKLIST,.NF)
+5 QUIT
+6 ;
+7 ;==========================================
SGENR(FILENUM,IEN,PACKLIST) ;General reminder global save routine, used for
+1 ;reminder globals that do not require special handling.
+2 NEW SPON
+3 DO SGEN(FILENUM,IEN,.PACKLIST)
+4 SET SPON=+$$GET1^DIQ(FILENUM,IEN,101,"I")
+5 IF SPON>0
DO SGEN(811.6,SPON,.PACKLIST)
+6 QUIT
+7 ;
+8 ;==========================================
SHF(FILENUM,IEN,PACKLIST) ;Health factors.
+1 NEW CAT,HF,NF
+2 ;All health factor references covered by DBIA #3083.
+3 ;If the health factor is a category then it has to be coming from
+4 ;a health summary so include all the health factors in the category.
+5 IF $PIECE(^AUTTHF(IEN,0),U,10)="C"
Begin DoDot:1
+6 SET CAT=1
SET HF=0
+7 FOR
SET HF=$ORDER(^AUTTHF("AC",IEN,HF))
IF HF'>0
QUIT
Begin DoDot:2
+8 DO EXISTS(FILENUM,HF,.PACKLIST)
+9 DO ADD(FILENUM,HF,.PACKLIST,.NF)
End DoDot:2
End DoDot:1
+10 DO EXISTS(FILENUM,IEN,.PACKLIST)
+11 DO ADD(FILENUM,IEN,.PACKLIST,.NF)
+12 IF $GET(CAT)
QUIT
+13 ;For a regular health factor make sure the category is on the list.
+14 SET CAT=$PIECE(^AUTTHF(IEN,0),U,3)
+15 DO EXISTS(FILENUM,CAT,.PACKLIST)
+16 SET NF=NF+1
+17 SET PACKLIST(FILENUM,NF)=CAT
+18 SET PACKLIST(FILENUM,"IEN",CAT)=NF
+19 QUIT
+20 ;
+21 ;==========================================
SHSO(FILENUM,IEN,PACKLIST) ;Health summary object.
+1 NEW HST
+2 DO SGEN(FILENUM,IEN,.PACKLIST)
+3 SET HST=$PIECE($GET(^GMT(142.5,IEN,0)),U,3)
+4 SET ROUTINE=$$GETSRTN(142)_"(142,HST,.PACKLIST)"
+5 DO @ROUTINE
+6 QUIT
+7 ;
+8 ;==========================================
SHST(FILENUM,IEN,PACKLIST) ;Health Summary Type
+1 NEW CNT,FNUM,GBL,HSC,ITEM,NODE,ROUTINE,SEL
+2 DO SGEN(FILENUM,IEN,.PACKLIST)
+3 SET CNT=0
FOR
SET CNT=$ORDER(^GMT(142,IEN,1,CNT))
IF CNT'>0
QUIT
Begin DoDot:1
+4 SET HSC=$PIECE($GET(^GMT(142,IEN,1,CNT,0)),U,2)
+5 SET ROUTINE=$$GETSRTN(142.1)_"(142.1,HSC,.PACKLIST)"
+6 DO @ROUTINE
+7 ;Loop through selection item, variable pointer
+8 SET SEL=0
FOR
SET SEL=$ORDER(^GMT(142,IEN,1,CNT,1,SEL))
IF SEL'>0
QUIT
Begin DoDot:2
+9 SET NODE=$PIECE($GET(^GMT(142,IEN,1,CNT,1,SEL,0)),U)
+10 IF NODE'=""
Begin DoDot:3
+11 SET ITEM=$PIECE(NODE,";",1)
+12 SET GBL=$PIECE(NODE,";",2)
+13 SET FNUM=$$GETFNUM(GBL)
+14 SET ROUTINE=$$GETSRTN(FNUM)_"(FNUM,ITEM,.PACKLIST)"
+15 IF ROUTINE="NOROUTINE"
QUIT
+16 DO @ROUTINE
End DoDot:3
End DoDot:2
End DoDot:1
+17 QUIT
+18 ;
+19 ;==========================================
SLL(FILENUM,IEN,PACKLIST) ;Reminder location lists.
+1 NEW CSTEXL,IND,ROUTINE
+2 DO SGEN(FILENUM,IEN,.PACKLIST)
+3 ;If CREDIT STOPS TO EXCLUDE (LIST) has been used put it on the packing
+4 ;list.
+5 SET IND=0
+6 FOR
SET IND=+$ORDER(^PXRMD(810.9,IEN,40.7,IND))
IF IND=0
QUIT
Begin DoDot:1
+7 SET CSTEXL=$GET(^PXRMD(810.9,IEN,40.7,IND,2))
+8 IF CSTEXL=""
QUIT
+9 SET ROUTINE=$$GETSRTN(810.9)_"(810.9,CSTEXL,.PACKLIST)"
+10 DO @ROUTINE
End DoDot:1
+11 ;Save information about hospital locations which are non-transportable.
+12 IF $DATA(^PXRMD(810.9,IEN,44))>1
DO NTHLOC^PXRMEXFI(IEN,"LOCATION LIST")
+13 QUIT
+14 ;
+15 ;==========================================
SLR(FILENUM,IEN,PACKLIST) ;Reminder list rules.
+1 NEW IND,LR,RDEF,RTERM,ROUTINE,TEMP
+2 DO SGEN(FILENUM,IEN,.PACKLIST)
+3 SET TEMP=^PXRM(810.4,IEN,0)
+4 SET RTERM=$PIECE(TEMP,U,7)
+5 IF RTERM'=""
Begin DoDot:1
+6 SET ROUTINE=$$GETSRTN(811.5)_"(811.5,RTERM,.PACKLIST)"
+7 DO @ROUTINE
End DoDot:1
+8 SET RDEF=$PIECE(TEMP,U,10)
+9 IF RDEF'=""
Begin DoDot:1
+10 SET ROUTINE=$$GETSRTN(811.9)_"(811.9,RDEF,.PACKLIST)"
+11 DO @ROUTINE
End DoDot:1
+12 ;If there is a sequence save the list rules.
+13 IF '$DATA(^PXRM(810.4,IEN,30))
QUIT
+14 SET ROUTINE=$$GETSRTN(810.4)_"(810.4,LR,.PACKLIST)"
+15 SET IND=0
+16 FOR
SET IND=+$ORDER(^PXRM(810.4,IEN,30,IND))
IF IND=0
QUIT
Begin DoDot:1
+17 SET LR=$PIECE(^PXRM(810.4,IEN,30,IND,0),U,2)
+18 DO @ROUTINE
End DoDot:1
+19 QUIT
+20 ;
+21 ;==========================================
SLT(FILENUM,IEN,PACKLIST) ;Lab tests
+1 IF +IEN'=IEN
SET IEN=$PIECE(IEN,";",3)
+2 DO SGEN(FILENUM,IEN,.PACKLIST)
+3 QUIT
+4 ;
+5 ;==========================================
SODIALOG(FILENUM,IEN,PACKLIST) ;Order dialogs.
+1 DO SGEN(FILENUM,IEN,.PACKLIST)
+2 ;DBIA 5446
+3 DO EN^ORORDDSC(IEN,"ORDER DIALOG")
+4 QUIT
+5 ;
+6 ;==========================================
SRCG(FILENUM,IEN,PACKLIST) ;Reminder counting groups.
+1 NEW IND,ROUTINE,TIEN
+2 DO SGEN(FILENUM,IEN,.PACKLIST)
+3 ;Put terms on the pack list.
+4 SET ROUTINE=$$GETSRTN(811.5)_"(811.5,TIEN,.PACKLIST)"
+5 SET IND=0
+6 FOR
SET IND=+$ORDER(^PXRM(810.8,IEN,10,IND))
IF IND=0
QUIT
Begin DoDot:1
+7 SET TIEN=$PIECE(^PXRM(810.8,IEN,10,IND,0),U,2)
+8 DO @ROUTINE
End DoDot:1
+9 QUIT
+10 ;
+11 ;==========================================
SRECR(FILENUM,IEN,PACKLIST) ;Reminder extract counting rule.
+1 NEW CGIEN,IND,ROUTINE,TIEN
+2 DO SGEN(FILENUM,IEN,.PACKLIST)
+3 ;Put counting groups on the pack list.
+4 SET ROUTINE=$$GETSRTN(810.8)_"(810.8,CGIEN,.PACKLIST)"
+5 SET IND=0
+6 FOR
SET IND=+$ORDER(^PXRM(810.7,IEN,10,IND))
IF IND=0
QUIT
Begin DoDot:1
+7 SET CGIEN=$PIECE(^PXRM(810.7,IEN,10,IND,0),U,2)
+8 DO @ROUTINE
End DoDot:1
+9 QUIT
+10 ;
+11 ;==========================================
SRT(FILENUM,TIEN,PACKLIST) ;Reminder terms.
+1 NEW FNUM,GBL,IEN,NF,ROUTINE,SPON
+2 NEW ITEM,NUM,RIEN
+3 DO EXISTS(FILENUM,TIEN,.PACKLIST)
+4 DO ADD(FILENUM,TIEN,.PACKLIST,.NF)
+5 ;Process the finding multiple.
+6 SET GBL=""
+7 FOR
SET GBL=$ORDER(^PXRMD(811.5,TIEN,20,"E",GBL))
IF GBL=""
QUIT
Begin DoDot:1
+8 SET FNUM=$$GETFNUM(GBL)
+9 IF FNUM=811.4
DO CHKCF("^PXRMD(811.5)",TIEN,GBL,.PACKLIST)
+10 SET ROUTINE=$$GETSRTN(FNUM)_"(FNUM,IEN,.PACKLIST)"
+11 SET IEN=""
+12 FOR
SET IEN=$ORDER(^PXRMD(811.5,TIEN,20,"E",GBL,IEN))
IF IEN=""
QUIT
DO @ROUTINE
End DoDot:1
+13 ;Sponsor
+14 SET SPON=+$PIECE(^PXRMD(811.5,TIEN,100),U,2)
+15 IF SPON>0
DO SGEN(811.6,SPON,.PACKLIST)
+16 QUIT
+17 ;
+18 ;==========================================
SROC(FILENUM,ROCIEN,PACKLIST) ;Reminder Order Checks.
+1 ;packed order check structure up
+2 DO SROC^BPXRMEX1(FILENUM,ROCIEN,PACKLIST)
+3 QUIT
+4 ;
+5 ;==========================================
SRULE(FILENUM,RULEIEN,PACKLIST) ;Reminder Order Check Rules.
+1 ;packed order check structure up
+2 DO SRULE^BPXRMEX1(FILENUM,RULEIEN,PACKLIST)
+3 QUIT
+4 ;
+5 ;==========================================
STIUOBJ(FILENUM,OLIST,PACKLIST) ;
+1 NEW ARY,CNT,HSO,IEN,NAME,ROUTINE,TEMP
+2 SET CNT=0
FOR
SET CNT=$ORDER(OLIST(CNT))
IF CNT'>0
QUIT
Begin DoDot:1
+3 SET NAME=OLIST(CNT)
+4 ;DBIA 5447
+5 SET IEN=$$OBJBYNAM^TIUCHECK(.ARY,NAME)
IF IEN=-1
QUIT
+6 ;Do not ship non TIU/HS Objects
+7 IF $GET(ARY(IEN,9))'["S X=$$TIU^GMTSOBJ("
Begin DoDot:2
+8 DO TIU^PXRMEXU5(IEN,.ARY,"TIU OBJECT")
+9 DO SGEN(FILENUM,IEN,.PACKLIST)
End DoDot:2
QUIT
+10 DO SGEN(FILENUM,IEN,.PACKLIST)
+11 SET TEMP=$PIECE($GET(ARY(IEN,9)),",",2)
+12 SET HSO=$PIECE(TEMP,")")
+13 SET ROUTINE=$$GETSRTN(142.5)_"(142.5,.HSO,.PACKLIST)"
+14 DO @ROUTINE
End DoDot:1
+15 QUIT
+16 ;
+17 ;==========================================
STIUTEMP(FILENUM,TLIST,PACKLIST) ;
+1 NEW CNT,IEN,NAME
+2 SET CNT=0
FOR
SET CNT=$ORDER(TLIST(CNT))
IF CNT'>0
QUIT
Begin DoDot:1
+3 SET NAME=TLIST(CNT)
+4 SET IEN=$ORDER(^TIU(8927.1,"B",NAME,""))
IF IEN'>0
QUIT
+5 DO SGEN(FILENUM,IEN,.PACKLIST)
End DoDot:1
+6 QUIT
+7 ;
