PXRMEXPS ;SLC/PKR - Packing save routines. ;02/14/2022
;;2.0;CLINICAL REMINDERS;**12,16,18,22,24,26,45,80**;Feb 04, 2005;Build 7
;
;DBIA
;3085 AUTTEDT(EDUIEN,10
;3083 AUTTHF(
;5246 GMT(142.5
;5247 GMT(142
;5446 BEG^ORORDDSC
;5447 $$OBJBYNAM^TIUCHECK
;3372 ^TIU(8927.1
;3110 $P(^ORD(101.41,IEN,0),U,4)
;==========================================
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,1)"
. 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=50.68 Q "SGEN^PXRMEXPS"
I FILENUM=60 Q "SLT^PXRMEXPS"
I FILENUM=71 Q "SGEN^PXRMEXPS"
I FILENUM=79.2 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=801.46 Q "SGEN^PXRMEXPS"
I FILENUM=801.47 Q "SDIALFUN^PXRMEXPS"
I FILENUM=801.48 Q "SDIALLNK^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"
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,NODIALOG) ;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
I +$G(NODIALOG)=1 Q
S DIALOG=+$G(^PXD(811.9,RIEN,51))
I DIALOG>0,'$D(PACKLIST(801.41,"IEN",DIALOG)) D SDIALOG(801.41,DIALOG,.PACKLIST)
Q
;
SDIALFUN(FILENUM,IEN,PACKLIST) ; Dialog Function File
D SGENR(FILENUM,IEN,.PACKLIST)
Q
;
SDIALLNK(FILENUM,IEN,PACKLIST) ; Dialog Link File
D SGENR(FILENUM,IEN,.PACKLIST)
N FUNC,ROUTINE
S FUNC=$P($G(^PXRMD(801.48,IEN,0)),U,4) Q:FUNC'>0
S ROUTINE=$$GETSRTN(801.47)_"(801.47,FUNC,.PACKLIST)"
D @ROUTINE
Q
;
;==========================================
SDIALOG(FILENUM,DIEN,PACKLIST) ;Reminder dialogs.
I DIEN'>0 Q
N EVALITEM,IDX,IEN,IND,IND1,FI,FNUM,GBL,MHT,OI,OLIST,REG,ROUTINE,SEQ,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) Q:+$G(IEN)'>0
.. S ^TMP($J,"PXRM DIALOG CHILDREN",IEN)=""
.. D @ROUTINE
.. S IEN=$P(^PXRMD(801.41,DIEN,10,IND,0),U,10) I +$G(IEN)'>0 Q
.. D @ROUTINE
;Check for a term and a replacement element/group.
I $D(^PXRMD(801.41,DIEN,"BL")) D
.S SEQ=0 F S SEQ=$O(^PXRMD(801.41,DIEN,"BL","B",SEQ)) Q:SEQ'>0 D
..S IDX=$O(^PXRMD(801.41,DIEN,"BL","B",SEQ,"")) Q:IDX'>0
..S TEMP=$G(^PXRMD(801.41,DIEN,"BL",IDX,0))
..S EVALITEM=$P(TEMP,U,2)
..I EVALITEM["811.9" D
... S ROUTINE=$$GETSRTN(811.9)_"(811.9,+EVALITEM,.PACKLIST,1)"
... D @ROUTINE
.. I EVALITEM["811.5" D
... S ROUTINE=$$GETSRTN(811.5)_"(811.5,+EVALITEM,.PACKLIST)"
... D @ROUTINE
.. S REG=$P(TEMP,U,5)
.. I REG>0 D
... S ^TMP($J,"PXRM DIALOG CHILDREN",REG)=""
... 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 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)
.. S ROUTINE=$$GETSRTN(801.41)_"(801.41,IEN,.PACKLIST)"
.. D @ROUTINE
.. ;S IEN=$P(^PXRMD(801.41,DIEN,51,IND,0),U,2) I +$G(IEN)'>0 Q
.. ;D @ROUTINE
.. ; check for linking on result group
.. S IND1=0 F S IND1=$O(^PXRMD(801.41,DIEN,51,IND,1,IND1)) Q:IND1'>0 D
... S IEN=$P($G(^PXRMD(801.41,DIEN,51,IND,1,IND1,0)),U,2) Q:IEN'>0
... S ROUTINE=$$GETSRTN(801.48)_"(801.48,IEN,.PACKLIST)"
... D @ROUTINE
;Check for linking
S IND=0 F S IND=$O(^PXRMD(801.41,DIEN,10,IND)) Q:IND'>0 D
.S IEN=$P($G(^PXRMD(801.41,DIEN,10,IND,"LINK")),U) Q:IEN'>0
.S ROUTINE=$$GETSRTN(801.48)_"(801.48,IEN,.PACKLIST)"
.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,1)"
;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,1)"
. 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
N CNT,OUTPUT,SUB,TYPE
S CNT=0,SUB="ORDER DIALOG"
S OUTPUT=$NA(^TMP($J,SUB,IEN))
S TYPE=$P($G(^ORD(101.41,IEN,0)),U,4)
D BEG^ORORDDSC(.OUTPUT,IEN,TYPE,.CNT)
S CNT=CNT+1,^TMP($J,SUB,IEN,CNT)=$$REPEAT^XLFSTR("-",79)
;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 SGENR(FILENUM,ROCIEN,.PACKLIST)
N GBL,SUB,DRCL,FNUM,ITEM,OI,OLIST,RIEN,ROUTINE,TIEN,TLIST,WPNODE
;Process the pharmacy multiple.
S ITEM=""
F S ITEM=$O(^PXD(801,ROCIEN,1.5,"B",ITEM)) Q:ITEM="" D
. S IEN=$P(ITEM,";"),GBL=$P(ITEM,";",2)
. S FNUM=$$GETFNUM(GBL)
. S ROUTINE=$$GETSRTN(FNUM)_"(FNUM,IEN,.PACKLIST)"
. D @ROUTINE
;loop through rules and packed definitions or terms
S SUB=0 F S SUB=$O(^PXD(801,ROCIEN,3,SUB)) Q:SUB'>0 D
.S RIEN=$P($G(^PXD(801,ROCIEN,3,SUB,0)),U) Q:RIEN'>0
.S ROUTINE=$$GETSRTN(801.1)_"(801.1,RIEN,.PACKLIST)"
.D @ROUTINE
Q
;
;==========================================
SRULE(FILENUM,RULEIEN,PACKLIST) ;Reminder Order Check Rules.
;packed order check structure up
D SGENR(FILENUM,RULEIEN,.PACKLIST)
N OLIST,RIEN,ROUTINE,TIEN,TLIST
I $D(^PXD(801.1,RULEIEN,3,4))>0 D
.;search for TIU Objects
.D TIUSRCH^PXRMEXU1("^PXD(801.1,",RULEIEN,",4",.OLIST,.TLIST)
.I $D(OLIST)>0 D
..S ROUTINE=$$GETSRTN(8925.1)_"(8925.1,.OLIST,.PACKLIST)"
..D @ROUTINE K OLIST
.K TLIST
.;packed term up only
S TIEN=$P($G(^PXD(801.1,RULEIEN,2)),U) I TIEN>0 D Q
.S ROUTINE=$$GETSRTN(811.5)_"(811.5,TIEN,.PACKLIST)"
.D @ROUTINE
;packed definition up if defined
S RIEN=$P($G(^PXD(801.1,RULEIEN,3)),U) I RIEN>0 D
.S ROUTINE=$$GETSRTN(811.9)_"(811.9,RIEN,.PACKLIST,1)"
.D @ROUTINE
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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMEXPS 17918 printed Sep 23, 2025@19:21:10 Page 2
PXRMEXPS ;SLC/PKR - Packing save routines. ;02/14/2022
+1 ;;2.0;CLINICAL REMINDERS;**12,16,18,22,24,26,45,80**;Feb 04, 2005;Build 7
+2 ;
+3 ;DBIA
+4 ;3085 AUTTEDT(EDUIEN,10
+5 ;3083 AUTTHF(
+6 ;5246 GMT(142.5
+7 ;5247 GMT(142
+8 ;5446 BEG^ORORDDSC
+9 ;5447 $$OBJBYNAM^TIUCHECK
+10 ;3372 ^TIU(8927.1
+11 ;3110 $P(^ORD(101.41,IEN,0),U,4)
+12 ;==========================================
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,1)"
+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=50.68
QUIT "SGEN^PXRMEXPS"
+5 IF FILENUM=60
QUIT "SLT^PXRMEXPS"
+6 IF FILENUM=71
QUIT "SGEN^PXRMEXPS"
+7 IF FILENUM=79.2
QUIT "SGEN^PXRMEXPS"
+8 IF FILENUM=80
QUIT "NOSAVE^PXRMEXPS"
+9 IF FILENUM=80.1
QUIT "NOSAVE^PXRMEXPS"
+10 IF FILENUM=81
QUIT "NOSAVE^PXRMEXPS"
+11 IF FILENUM=101.41
QUIT "SODIALOG^PXRMEXPS"
+12 IF FILENUM=101.43
QUIT "SGEN^PXRMEXPS"
+13 IF FILENUM=120.51
QUIT "SGEN^PXRMEXPS"
+14 IF FILENUM=142
QUIT "SHST^PXRMEXPS"
+15 IF FILENUM=142.1
QUIT "SGEN^PXRMEXPS"
+16 IF FILENUM=142.5
QUIT "SHSO^PXRMEXPS"
+17 IF FILENUM=601.71
QUIT "SGEN^PXRMEXPS"
+18 IF FILENUM=790.404
QUIT "SGEN^PXRMEXPS"
+19 IF FILENUM=801
QUIT "SROC^PXRMEXPS"
+20 IF FILENUM=801.1
QUIT "SRULE^PXRMEXPS"
+21 IF FILENUM=801.41
QUIT "SDIALOG^PXRMEXPS"
+22 IF FILENUM=801.46
QUIT "SGEN^PXRMEXPS"
+23 IF FILENUM=801.47
QUIT "SDIALFUN^PXRMEXPS"
+24 IF FILENUM=801.48
QUIT "SDIALLNK^PXRMEXPS"
+25 IF FILENUM=810.2
QUIT "SEDEF^PXRMEXPS"
+26 IF FILENUM=810.4
QUIT "SLR^PXRMEXPS"
+27 IF FILENUM=810.7
QUIT "SRECR^PXRMEXPS"
+28 IF FILENUM=810.8
QUIT "SRCG^PXRMEXPS"
+29 IF FILENUM=810.9
QUIT "SLL^PXRMEXPS"
+30 IF FILENUM=811.2
QUIT "SGENR^PXRMEXPS"
+31 IF FILENUM=811.4
QUIT "SCF^PXRMEXPS"
+32 IF FILENUM=811.5
QUIT "SRT^PXRMEXPS"
+33 IF FILENUM=811.6
QUIT "SGEN^PXRMEXPS"
+34 IF FILENUM=811.9
QUIT "SDEF^PXRMEXPS"
+35 IF FILENUM=8925.1
QUIT "STIUOBJ^PXRMEXPS"
+36 IF FILENUM=8927.1
QUIT "STIUTEMP^PXRMEXPS"
+37 IF FILENUM=9999999.09
QUIT "SED^PXRMEXPS"
+38 IF FILENUM=9999999.14
QUIT "SGEN^PXRMEXPS"
+39 IF FILENUM=9999999.15
QUIT "SGEN^PXRMEXPS"
+40 IF FILENUM=9999999.28
QUIT "SGEN^PXRMEXPS"
+41 IF FILENUM=9999999.64
QUIT "SHF^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,NODIALOG) ;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 IF +$GET(NODIALOG)=1
QUIT
+15 SET DIALOG=+$GET(^PXD(811.9,RIEN,51))
+16 IF DIALOG>0
IF '$DATA(PACKLIST(801.41,"IEN",DIALOG))
DO SDIALOG(801.41,DIALOG,.PACKLIST)
+17 QUIT
+18 ;
SDIALFUN(FILENUM,IEN,PACKLIST) ; Dialog Function File
+1 DO SGENR(FILENUM,IEN,.PACKLIST)
+2 QUIT
+3 ;
SDIALLNK(FILENUM,IEN,PACKLIST) ; Dialog Link File
+1 DO SGENR(FILENUM,IEN,.PACKLIST)
+2 NEW FUNC,ROUTINE
+3 SET FUNC=$PIECE($GET(^PXRMD(801.48,IEN,0)),U,4)
if FUNC'>0
QUIT
+4 SET ROUTINE=$$GETSRTN(801.47)_"(801.47,FUNC,.PACKLIST)"
+5 DO @ROUTINE
+6 QUIT
+7 ;
+8 ;==========================================
SDIALOG(FILENUM,DIEN,PACKLIST) ;Reminder dialogs.
+1 IF DIEN'>0
QUIT
+2 NEW EVALITEM,IDX,IEN,IND,IND1,FI,FNUM,GBL,MHT,OI,OLIST,REG,ROUTINE,SEQ,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)
if +$GET(IEN)'>0
QUIT
+48 SET ^TMP($JOB,"PXRM DIALOG CHILDREN",IEN)=""
+49 DO @ROUTINE
+50 SET IEN=$PIECE(^PXRMD(801.41,DIEN,10,IND,0),U,10)
IF +$GET(IEN)'>0
QUIT
+51 DO @ROUTINE
End DoDot:2
End DoDot:1
+52 ;Check for a term and a replacement element/group.
+53 IF $DATA(^PXRMD(801.41,DIEN,"BL"))
Begin DoDot:1
+54 SET SEQ=0
FOR
SET SEQ=$ORDER(^PXRMD(801.41,DIEN,"BL","B",SEQ))
if SEQ'>0
QUIT
Begin DoDot:2
+55 SET IDX=$ORDER(^PXRMD(801.41,DIEN,"BL","B",SEQ,""))
if IDX'>0
QUIT
+56 SET TEMP=$GET(^PXRMD(801.41,DIEN,"BL",IDX,0))
+57 SET EVALITEM=$PIECE(TEMP,U,2)
+58 IF EVALITEM["811.9"
Begin DoDot:3
+59 SET ROUTINE=$$GETSRTN(811.9)_"(811.9,+EVALITEM,.PACKLIST,1)"
+60 DO @ROUTINE
End DoDot:3
+61 IF EVALITEM["811.5"
Begin DoDot:3
+62 SET ROUTINE=$$GETSRTN(811.5)_"(811.5,+EVALITEM,.PACKLIST)"
+63 DO @ROUTINE
End DoDot:3
+64 SET REG=$PIECE(TEMP,U,5)
+65 IF REG>0
Begin DoDot:3
+66 SET ^TMP($JOB,"PXRM DIALOG CHILDREN",REG)=""
+67 SET ROUTINE=$$GETSRTN(801.41)_"(801.41,REG,.PACKLIST)"
+68 DO @ROUTINE
End DoDot:3
End DoDot:2
End DoDot:1
+69 ;Check for a mental health test.
+70 SET MHT=$PIECE($GET(^PXRMD(801.41,DIEN,50)),U,1)
+71 IF MHT'=""
Begin DoDot:1
+72 SET ROUTINE=$$GETSRTN(601.71)_"(601.71,MHT,.PACKLIST)"
+73 DO @ROUTINE
End DoDot:1
+74 ;Check for result groups.
+75 IF $DATA(^PXRMD(801.41,DIEN,51))
Begin DoDot:1
+76 SET IND=0
+77 FOR
SET IND=+$ORDER(^PXRMD(801.41,DIEN,51,IND))
if IND=0
QUIT
Begin DoDot:2
+78 SET IEN=$PIECE(^PXRMD(801.41,DIEN,51,IND,0),U,1)
+79 SET ROUTINE=$$GETSRTN(801.41)_"(801.41,IEN,.PACKLIST)"
+80 DO @ROUTINE
+81 ;S IEN=$P(^PXRMD(801.41,DIEN,51,IND,0),U,2) I +$G(IEN)'>0 Q
+82 ;D @ROUTINE
+83 ; check for linking on result group
+84 SET IND1=0
FOR
SET IND1=$ORDER(^PXRMD(801.41,DIEN,51,IND,1,IND1))
if IND1'>0
QUIT
Begin DoDot:3
+85 SET IEN=$PIECE($GET(^PXRMD(801.41,DIEN,51,IND,1,IND1,0)),U,2)
if IEN'>0
QUIT
+86 SET ROUTINE=$$GETSRTN(801.48)_"(801.48,IEN,.PACKLIST)"
+87 DO @ROUTINE
End DoDot:3
End DoDot:2
End DoDot:1
+88 ;Check for linking
+89 SET IND=0
FOR
SET IND=$ORDER(^PXRMD(801.41,DIEN,10,IND))
if IND'>0
QUIT
Begin DoDot:1
+90 SET IEN=$PIECE($GET(^PXRMD(801.41,DIEN,10,IND,"LINK")),U)
if IEN'>0
QUIT
+91 SET ROUTINE=$$GETSRTN(801.48)_"(801.48,IEN,.PACKLIST)"
+92 DO @ROUTINE
End DoDot:1
+93 QUIT
+94 ;
+95 ;==========================================
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,1)"
+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,1)"
+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 NEW CNT,OUTPUT,SUB,TYPE
+4 SET CNT=0
SET SUB="ORDER DIALOG"
+5 SET OUTPUT=$NAME(^TMP($JOB,SUB,IEN))
+6 SET TYPE=$PIECE($GET(^ORD(101.41,IEN,0)),U,4)
+7 DO BEG^ORORDDSC(.OUTPUT,IEN,TYPE,.CNT)
+8 SET CNT=CNT+1
SET ^TMP($JOB,SUB,IEN,CNT)=$$REPEAT^XLFSTR("-",79)
+9 ;D EN^ORORDDSC(IEN,"ORDER DIALOG")
+10 QUIT
+11 ;
+12 ;==========================================
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 SGENR(FILENUM,ROCIEN,.PACKLIST)
+3 NEW GBL,SUB,DRCL,FNUM,ITEM,OI,OLIST,RIEN,ROUTINE,TIEN,TLIST,WPNODE
+4 ;Process the pharmacy multiple.
+5 SET ITEM=""
+6 FOR
SET ITEM=$ORDER(^PXD(801,ROCIEN,1.5,"B",ITEM))
if ITEM=""
QUIT
Begin DoDot:1
+7 SET IEN=$PIECE(ITEM,";")
SET GBL=$PIECE(ITEM,";",2)
+8 SET FNUM=$$GETFNUM(GBL)
+9 SET ROUTINE=$$GETSRTN(FNUM)_"(FNUM,IEN,.PACKLIST)"
+10 DO @ROUTINE
End DoDot:1
+11 ;loop through rules and packed definitions or terms
+12 SET SUB=0
FOR
SET SUB=$ORDER(^PXD(801,ROCIEN,3,SUB))
if SUB'>0
QUIT
Begin DoDot:1
+13 SET RIEN=$PIECE($GET(^PXD(801,ROCIEN,3,SUB,0)),U)
if RIEN'>0
QUIT
+14 SET ROUTINE=$$GETSRTN(801.1)_"(801.1,RIEN,.PACKLIST)"
+15 DO @ROUTINE
End DoDot:1
+16 QUIT
+17 ;
+18 ;==========================================
SRULE(FILENUM,RULEIEN,PACKLIST) ;Reminder Order Check Rules.
+1 ;packed order check structure up
+2 DO SGENR(FILENUM,RULEIEN,.PACKLIST)
+3 NEW OLIST,RIEN,ROUTINE,TIEN,TLIST
+4 IF $DATA(^PXD(801.1,RULEIEN,3,4))>0
Begin DoDot:1
+5 ;search for TIU Objects
+6 DO TIUSRCH^PXRMEXU1("^PXD(801.1,",RULEIEN,",4",.OLIST,.TLIST)
+7 IF $DATA(OLIST)>0
Begin DoDot:2
+8 SET ROUTINE=$$GETSRTN(8925.1)_"(8925.1,.OLIST,.PACKLIST)"
+9 DO @ROUTINE
KILL OLIST
End DoDot:2
+10 KILL TLIST
+11 ;packed term up only
End DoDot:1
+12 SET TIEN=$PIECE($GET(^PXD(801.1,RULEIEN,2)),U)
IF TIEN>0
Begin DoDot:1
+13 SET ROUTINE=$$GETSRTN(811.5)_"(811.5,TIEN,.PACKLIST)"
+14 DO @ROUTINE
End DoDot:1
QUIT
+15 ;packed definition up if defined
+16 SET RIEN=$PIECE($GET(^PXD(801.1,RULEIEN,3)),U)
IF RIEN>0
Begin DoDot:1
+17 SET ROUTINE=$$GETSRTN(811.9)_"(811.9,RIEN,.PACKLIST,1)"
+18 DO @ROUTINE
End DoDot:1
+19 QUIT
+20 ;
+21 ;==========================================
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 ;
