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