Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PXRMEXPS

PXRMEXPS.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;DBIA
  1. ;3085 AUTTEDT(EDUIEN,10
  1. ;3083 AUTTHF(
  1. ;5246 GMT(142.5
  1. ;5247 GMT(142
  1. ;5446 BEG^ORORDDSC
  1. ;5447 $$OBJBYNAM^TIUCHECK
  1. ;3372 ^TIU(8927.1
  1. ;3110 $P(^ORD(101.41,IEN,0),U,4)
  1. ;==========================================
  1. ADD(FILENUM,IEN,PACKLIST,NF) ;
  1. S NF=+$O(PACKLIST(FILENUM,"IEN"),-1)+1
  1. S PACKLIST(FILENUM,NF)=IEN
  1. S PACKLIST(FILENUM,"IEN",IEN)=NF
  1. Q
  1. ;
  1. ;==========================================
  1. CHKCF(ROOT,TOPIEN,GBL,PACKLIST) ;
  1. N IEN,NAME,NUM,PARM,RIEN,ROUTINE
  1. S IEN=""
  1. F S IEN=$O(@ROOT@(TOPIEN,20,"E",GBL,IEN)) Q:IEN="" D
  1. . I $P($G(^PXRMD(811.4,IEN,0)),U,1)'="VA-REMINDER DEFINITION" Q
  1. . S NUM=$O(@ROOT@(TOPIEN,20,"E",GBL,IEN,"")) Q:NUM'>0
  1. . S PARM=$P($G(@ROOT@(TOPIEN,20,NUM,15)),U,1)
  1. . S NAME=$P(PARM,U,1)
  1. . S RIEN=$O(^PXD(811.9,"B",NAME,"")) Q:RIEN'>0
  1. . S ROUTINE=$$GETSRTN(811.9)_"(811.9,RIEN,.PACKLIST,1)"
  1. . D @ROUTINE
  1. Q
  1. ;
  1. ;==========================================
  1. EXISTS(FILENUM,IEN,PACKLIST) ;If the entry already exists remove it
  1. ;and keep only the higher entry.
  1. I '$D(PACKLIST(FILENUM,"IEN",IEN)) Q
  1. N NUM
  1. S NUM=PACKLIST(FILENUM,"IEN",IEN)
  1. K PACKLIST(FILENUM,NUM)
  1. Q
  1. ;
  1. ;==========================================
  1. GEDSUB(EDUIEN,NSUB,LIST) ;Build the recursive list of education topic
  1. ;subtopics.
  1. ;DBIA #3085
  1. N IND,SUBIEN
  1. S IND=0
  1. F S IND=+$O(^AUTTEDT(EDUIEN,10,IND)) Q:IND=0 D
  1. . S NSUB=NSUB+1
  1. . S SUBIEN=$P(^AUTTEDT(EDUIEN,10,IND,0),U,1)
  1. . S LIST(NSUB)=SUBIEN
  1. . D GEDSUB(SUBIEN,.NSUB,.LIST)
  1. Q
  1. ;
  1. ;==========================================
  1. GETFNUM(GBL) ;Return the file number for a global.
  1. S GBL="^"_GBL_"0)"
  1. Q +$P(@GBL,U,2)
  1. ;
  1. ;==========================================
  1. GETSRTN(FILENUM) ;Return the save routine according to the file number.
  1. I FILENUM=50 Q "SGEN^PXRMEXPS"
  1. I FILENUM=50.6 Q "SGEN^PXRMEXPS"
  1. I FILENUM=50.605 Q "SGEN^PXRMEXPS"
  1. I FILENUM=50.68 Q "SGEN^PXRMEXPS"
  1. I FILENUM=60 Q "SLT^PXRMEXPS"
  1. I FILENUM=71 Q "SGEN^PXRMEXPS"
  1. I FILENUM=79.2 Q "SGEN^PXRMEXPS"
  1. I FILENUM=80 Q "NOSAVE^PXRMEXPS"
  1. I FILENUM=80.1 Q "NOSAVE^PXRMEXPS"
  1. I FILENUM=81 Q "NOSAVE^PXRMEXPS"
  1. I FILENUM=101.41 Q "SODIALOG^PXRMEXPS"
  1. I FILENUM=101.43 Q "SGEN^PXRMEXPS"
  1. I FILENUM=120.51 Q "SGEN^PXRMEXPS"
  1. I FILENUM=142 Q "SHST^PXRMEXPS"
  1. I FILENUM=142.1 Q "SGEN^PXRMEXPS"
  1. I FILENUM=142.5 Q "SHSO^PXRMEXPS"
  1. I FILENUM=601.71 Q "SGEN^PXRMEXPS"
  1. I FILENUM=790.404 Q "SGEN^PXRMEXPS"
  1. I FILENUM=801 Q "SROC^PXRMEXPS"
  1. I FILENUM=801.1 Q "SRULE^PXRMEXPS"
  1. I FILENUM=801.41 Q "SDIALOG^PXRMEXPS"
  1. I FILENUM=801.46 Q "SGEN^PXRMEXPS"
  1. I FILENUM=801.47 Q "SDIALFUN^PXRMEXPS"
  1. I FILENUM=801.48 Q "SDIALLNK^PXRMEXPS"
  1. I FILENUM=810.2 Q "SEDEF^PXRMEXPS"
  1. I FILENUM=810.4 Q "SLR^PXRMEXPS"
  1. I FILENUM=810.7 Q "SRECR^PXRMEXPS"
  1. I FILENUM=810.8 Q "SRCG^PXRMEXPS"
  1. I FILENUM=810.9 Q "SLL^PXRMEXPS"
  1. I FILENUM=811.2 Q "SGENR^PXRMEXPS"
  1. I FILENUM=811.4 Q "SCF^PXRMEXPS"
  1. I FILENUM=811.5 Q "SRT^PXRMEXPS"
  1. I FILENUM=811.6 Q "SGEN^PXRMEXPS"
  1. I FILENUM=811.9 Q "SDEF^PXRMEXPS"
  1. I FILENUM=8925.1 Q "STIUOBJ^PXRMEXPS"
  1. I FILENUM=8927.1 Q "STIUTEMP^PXRMEXPS"
  1. I FILENUM=9999999.09 Q "SED^PXRMEXPS"
  1. I FILENUM=9999999.14 Q "SGEN^PXRMEXPS"
  1. I FILENUM=9999999.15 Q "SGEN^PXRMEXPS"
  1. I FILENUM=9999999.28 Q "SGEN^PXRMEXPS"
  1. I FILENUM=9999999.64 Q "SHF^PXRMEXPS"
  1. Q "NORTN^PXRMEXPS"
  1. ;
  1. ;==========================================
  1. NORTN(FILENUM,IEN,PACKLIST) ;Don't have a routine for this file number.
  1. S NF=+$O(PACKLIST(FILENUM,"IEN"),-1)+1
  1. S PACKLIST(FILENUM,NF)=IEN
  1. S PACKLIST(FILENUM,"IEN",IEN)=NF
  1. S PACKLIST(FILENUM,"ERROR",IEN)="No packing routine for file number "_FILENUM_"."
  1. Q
  1. ;
  1. ;==========================================
  1. NOSAVE(FILENUM,IEN,PACKLIST) ;Don't do anything for this file number.
  1. Q
  1. ;
  1. ;==========================================
  1. SCF(FILENUM,IEN,PACKLIST) ;Reminder computed findings.
  1. N CFRTN
  1. ;Add the computed finding file entry.
  1. D SGENR(FILENUM,IEN,.PACKLIST)
  1. S CFRTN=$P(^PXRMD(811.4,IEN,0),U,2)
  1. ;Add the routine; mark routines with file number 0.
  1. D SGEN(0,CFRTN,.PACKLIST)
  1. Q
  1. ;
  1. ;==========================================
  1. SDEF(FILENUM,RIEN,PACKLIST,NODIALOG) ;Reminder definitions.
  1. N DIALOG,ENODE,EO,FINDING,FINUM,FNUM,GBL,IEN,NF,ROUTINE,SPON
  1. D SGENR(FILENUM,RIEN,.PACKLIST)
  1. ;Process the finding multiple.
  1. S FINUM=0
  1. F S FINUM=+$O(^PXD(811.9,RIEN,20,FINUM)) Q:FINUM=0 D
  1. . S FINDING=$P(^PXD(811.9,RIEN,20,FINUM,0),U,1)
  1. . S IEN=$P(FINDING,";",1)
  1. . S GBL=$P(FINDING,";",2)
  1. . S FNUM=$$GETFNUM(GBL)
  1. . I FNUM=811.4 D CHKCF("^PXD(811.9)",RIEN,GBL,.PACKLIST)
  1. . S ROUTINE=$$GETSRTN(FNUM)_"(FNUM,IEN,.PACKLIST)"
  1. . D @ROUTINE
  1. ;Dialog
  1. I +$G(NODIALOG)=1 Q
  1. S DIALOG=+$G(^PXD(811.9,RIEN,51))
  1. I DIALOG>0,'$D(PACKLIST(801.41,"IEN",DIALOG)) D SDIALOG(801.41,DIALOG,.PACKLIST)
  1. Q
  1. ;
  1. SDIALFUN(FILENUM,IEN,PACKLIST) ; Dialog Function File
  1. D SGENR(FILENUM,IEN,.PACKLIST)
  1. Q
  1. ;
  1. SDIALLNK(FILENUM,IEN,PACKLIST) ; Dialog Link File
  1. D SGENR(FILENUM,IEN,.PACKLIST)
  1. N FUNC,ROUTINE
  1. S FUNC=$P($G(^PXRMD(801.48,IEN,0)),U,4) Q:FUNC'>0
  1. S ROUTINE=$$GETSRTN(801.47)_"(801.47,FUNC,.PACKLIST)"
  1. D @ROUTINE
  1. Q
  1. ;
  1. ;==========================================
  1. SDIALOG(FILENUM,DIEN,PACKLIST) ;Reminder dialogs.
  1. I DIEN'>0 Q
  1. N EVALITEM,IDX,IEN,IND,IND1,FI,FNUM,GBL,MHT,OI,OLIST,REG,ROUTINE,SEQ,TEMP,TERM,TLIST
  1. D SGENR(FILENUM,DIEN,.PACKLIST)
  1. ;Check for a finding item.
  1. S TEMP=$G(^PXRMD(801.41,DIEN,1))
  1. S FI=$P(TEMP,U,5)
  1. I FI'="" D
  1. . S IEN=$P(FI,";",1)
  1. . S GBL=$P(FI,";",2)
  1. . S FNUM=$$GETFNUM(GBL)
  1. . S ROUTINE=$$GETSRTN(FNUM)_"(FNUM,IEN,.PACKLIST)"
  1. . D @ROUTINE
  1. ;Check for an orderable item.
  1. S OI=$P(TEMP,U,7)
  1. I OI'="" D
  1. . S ROUTINE=$$GETSRTN(101.43)_"(101.43,OI,.PACKLIST)"
  1. . D @ROUTINE
  1. ;Check for additional findings.
  1. S IND=0
  1. F S IND=+$O(^PXRMD(801.41,DIEN,3,IND)) Q:IND=0 D
  1. . S FI=$P(^PXRMD(801.41,DIEN,3,IND,0),U,1)
  1. . S IEN=$P(FI,";",1)
  1. . S GBL=$P(FI,";",2)
  1. . S FNUM=$$GETFNUM(GBL)
  1. . S ROUTINE=$$GETSRTN(FNUM)_"(FNUM,IEN,.PACKLIST)"
  1. . D @ROUTINE
  1. ;Check word processing fields for TIU Object and Template Fields
  1. D TIUSRCH^PXRMEXU1("^PXRMD(801.41,",DIEN,25,.OLIST,.TLIST)
  1. I $D(OLIST)>0 D
  1. . S ROUTINE=$$GETSRTN(8925.1)_"(8925.1,.OLIST,.PACKLIST)"
  1. . D @ROUTINE K OLIST
  1. I $D(TLIST)>0 D
  1. . S ROUTINE=$$GETSRTN(8927.1)_"(8927.1,.TLIST,.PACKLIST)"
  1. . D @ROUTINE K TLIST
  1. D TIUSRCH^PXRMEXU1("^PXRMD(801.41,",DIEN,35,.OLIST,.TLIST)
  1. I $D(OLIST)>0 D
  1. . S ROUTINE=$$GETSRTN(8925.1)_"(8925.1,.OLIST,.PACKLIST)"
  1. . D @ROUTINE K OLIST
  1. I $D(TLIST)>0 D
  1. . S ROUTINE=$$GETSRTN(8927.1)_"(8927.1,.TLIST,.PACKLIST)"
  1. . D @ROUTINE K TLIST
  1. ;Check the components multiple for elements.
  1. I $D(^PXRMD(801.41,DIEN,10)) D
  1. . S ROUTINE=$$GETSRTN(801.41)_"(801.41,IEN,.PACKLIST)"
  1. . S IND=0
  1. . F S IND=+$O(^PXRMD(801.41,DIEN,10,IND)) Q:IND=0 D
  1. .. S IEN=$P(^PXRMD(801.41,DIEN,10,IND,0),U,2) Q:+$G(IEN)'>0
  1. .. S ^TMP($J,"PXRM DIALOG CHILDREN",IEN)=""
  1. .. D @ROUTINE
  1. .. S IEN=$P(^PXRMD(801.41,DIEN,10,IND,0),U,10) I +$G(IEN)'>0 Q
  1. .. D @ROUTINE
  1. ;Check for a term and a replacement element/group.
  1. I $D(^PXRMD(801.41,DIEN,"BL")) D
  1. .S SEQ=0 F S SEQ=$O(^PXRMD(801.41,DIEN,"BL","B",SEQ)) Q:SEQ'>0 D
  1. ..S IDX=$O(^PXRMD(801.41,DIEN,"BL","B",SEQ,"")) Q:IDX'>0
  1. ..S TEMP=$G(^PXRMD(801.41,DIEN,"BL",IDX,0))
  1. ..S EVALITEM=$P(TEMP,U,2)
  1. ..I EVALITEM["811.9" D
  1. ... S ROUTINE=$$GETSRTN(811.9)_"(811.9,+EVALITEM,.PACKLIST,1)"
  1. ... D @ROUTINE
  1. .. I EVALITEM["811.5" D
  1. ... S ROUTINE=$$GETSRTN(811.5)_"(811.5,+EVALITEM,.PACKLIST)"
  1. ... D @ROUTINE
  1. .. S REG=$P(TEMP,U,5)
  1. .. I REG>0 D
  1. ... S ^TMP($J,"PXRM DIALOG CHILDREN",REG)=""
  1. ... S ROUTINE=$$GETSRTN(801.41)_"(801.41,REG,.PACKLIST)"
  1. ... D @ROUTINE
  1. ;Check for a mental health test.
  1. S MHT=$P($G(^PXRMD(801.41,DIEN,50)),U,1)
  1. I MHT'="" D
  1. . S ROUTINE=$$GETSRTN(601.71)_"(601.71,MHT,.PACKLIST)"
  1. . D @ROUTINE
  1. ;Check for result groups.
  1. I $D(^PXRMD(801.41,DIEN,51)) D
  1. . S IND=0
  1. . F S IND=+$O(^PXRMD(801.41,DIEN,51,IND)) Q:IND=0 D
  1. .. S IEN=$P(^PXRMD(801.41,DIEN,51,IND,0),U,1)
  1. .. S ROUTINE=$$GETSRTN(801.41)_"(801.41,IEN,.PACKLIST)"
  1. .. D @ROUTINE
  1. .. ;S IEN=$P(^PXRMD(801.41,DIEN,51,IND,0),U,2) I +$G(IEN)'>0 Q
  1. .. ;D @ROUTINE
  1. .. ; check for linking on result group
  1. .. S IND1=0 F S IND1=$O(^PXRMD(801.41,DIEN,51,IND,1,IND1)) Q:IND1'>0 D
  1. ... S IEN=$P($G(^PXRMD(801.41,DIEN,51,IND,1,IND1,0)),U,2) Q:IEN'>0
  1. ... S ROUTINE=$$GETSRTN(801.48)_"(801.48,IEN,.PACKLIST)"
  1. ... D @ROUTINE
  1. ;Check for linking
  1. S IND=0 F S IND=$O(^PXRMD(801.41,DIEN,10,IND)) Q:IND'>0 D
  1. .S IEN=$P($G(^PXRMD(801.41,DIEN,10,IND,"LINK")),U) Q:IEN'>0
  1. .S ROUTINE=$$GETSRTN(801.48)_"(801.48,IEN,.PACKLIST)"
  1. .D @ROUTINE
  1. Q
  1. ;
  1. ;==========================================
  1. SED(FILENUM,IEN,PACKLIST) ;Education topics.
  1. N IND,NF,NSUB,SUBLIST
  1. D EXISTS(FILENUM,IEN,.PACKLIST)
  1. D ADD(FILENUM,IEN,.PACKLIST,.NF)
  1. S NSUB=0
  1. ;Get all the subtopics.
  1. D GEDSUB(IEN,.NSUB,.SUBLIST)
  1. F IND=1:1:NSUB D
  1. . D EXISTS(FILENUM,SUBLIST(IND),.PACKLIST)
  1. . S NF=NF+1
  1. . S PACKLIST(FILENUM,NF)=SUBLIST(IND)
  1. . S PACKLIST(FILENUM,"IEN",SUBLIST(IND))=NF
  1. Q
  1. ;
  1. ;==========================================
  1. SEDEF(FILENUM,IEN,PACKLIST) ;Reminder extract definitions.
  1. N CR,CRRTN,IND,JND,LRRTN,LRS,RDEF,RDEFRTN,TEMP
  1. D SGEN(FILENUM,IEN,.PACKLIST)
  1. ;Initialize the save routines.
  1. S LRRTN=$$GETSRTN(810.4)_"(810.4,LRS,.PACKLIST)"
  1. S CRRTN=$$GETSRTN(810.7)_"(810.7,CR,.PACKLIST)"
  1. S RDEFRTN=$$GETSRTN(811.9)_"(811.9,RDEF,.PACKLIST,1)"
  1. ;Go through the extract sequence.
  1. S IND=0
  1. F S IND=+$O(^PXRM(810.2,IEN,10,IND)) Q:IND=0 D
  1. . S LRS=$P(^PXRM(810.2,IEN,10,IND,0),U,2)
  1. . D @LRRTN
  1. .;Go through the reminders and counting rules.
  1. . S JND=0
  1. . F S JND=+$O(^PXRM(810.2,IEN,10,IND,10,JND)) Q:JND=0 D
  1. .. S TEMP=^PXRM(810.2,IEN,10,IND,10,JND,0)
  1. .. S RDEF=$P(TEMP,U,2)
  1. .. I RDEF'="" D @RDEFRTN
  1. .. S CR=$P(TEMP,U,3)
  1. .. I CR'="" D @CRRTN
  1. Q
  1. ;
  1. ;==========================================
  1. SGEN(FILENUM,IEN,PACKLIST) ;General save routine, used for everything that
  1. ;does not require special handling.
  1. N NF
  1. D EXISTS(FILENUM,IEN,.PACKLIST)
  1. D ADD(FILENUM,IEN,.PACKLIST,.NF)
  1. Q
  1. ;
  1. ;==========================================
  1. SGENR(FILENUM,IEN,PACKLIST) ;General reminder global save routine, used for
  1. ;reminder globals that do not require special handling.
  1. N SPON
  1. D SGEN(FILENUM,IEN,.PACKLIST)
  1. S SPON=+$$GET1^DIQ(FILENUM,IEN,101,"I")
  1. I SPON>0 D SGEN(811.6,SPON,.PACKLIST)
  1. Q
  1. ;
  1. ;==========================================
  1. SHF(FILENUM,IEN,PACKLIST) ;Health factors.
  1. N CAT,HF,NF
  1. ;All health factor references covered by DBIA #3083.
  1. ;If the health factor is a category then it has to be coming from
  1. ;a health summary so include all the health factors in the category.
  1. I $P(^AUTTHF(IEN,0),U,10)="C" D
  1. . S CAT=1,HF=0
  1. . F S HF=$O(^AUTTHF("AC",IEN,HF)) Q:HF'>0 D
  1. .. D EXISTS(FILENUM,HF,.PACKLIST)
  1. .. D ADD(FILENUM,HF,.PACKLIST,.NF)
  1. D EXISTS(FILENUM,IEN,.PACKLIST)
  1. D ADD(FILENUM,IEN,.PACKLIST,.NF)
  1. I $G(CAT) Q
  1. ;For a regular health factor make sure the category is on the list.
  1. S CAT=$P(^AUTTHF(IEN,0),U,3)
  1. D EXISTS(FILENUM,CAT,.PACKLIST)
  1. S NF=NF+1
  1. S PACKLIST(FILENUM,NF)=CAT
  1. S PACKLIST(FILENUM,"IEN",CAT)=NF
  1. Q
  1. ;
  1. ;==========================================
  1. SHSO(FILENUM,IEN,PACKLIST) ;Health summary object.
  1. N HST
  1. D SGEN(FILENUM,IEN,.PACKLIST)
  1. S HST=$P($G(^GMT(142.5,IEN,0)),U,3)
  1. S ROUTINE=$$GETSRTN(142)_"(142,HST,.PACKLIST)"
  1. D @ROUTINE
  1. Q
  1. ;
  1. ;==========================================
  1. SHST(FILENUM,IEN,PACKLIST) ;Health Summary Type
  1. N CNT,FNUM,GBL,HSC,ITEM,NODE,ROUTINE,SEL
  1. D SGEN(FILENUM,IEN,.PACKLIST)
  1. S CNT=0 F S CNT=$O(^GMT(142,IEN,1,CNT)) Q:CNT'>0 D
  1. .S HSC=$P($G(^GMT(142,IEN,1,CNT,0)),U,2)
  1. .S ROUTINE=$$GETSRTN(142.1)_"(142.1,HSC,.PACKLIST)"
  1. .D @ROUTINE
  1. .;Loop through selection item, variable pointer
  1. .S SEL=0 F S SEL=$O(^GMT(142,IEN,1,CNT,1,SEL)) Q:SEL'>0 D
  1. ..S NODE=$P($G(^GMT(142,IEN,1,CNT,1,SEL,0)),U)
  1. ..I NODE'="" D
  1. ...S ITEM=$P(NODE,";",1)
  1. ...S GBL=$P(NODE,";",2)
  1. ...S FNUM=$$GETFNUM(GBL)
  1. ...S ROUTINE=$$GETSRTN(FNUM)_"(FNUM,ITEM,.PACKLIST)"
  1. ...I ROUTINE="NOROUTINE" Q
  1. ...D @ROUTINE
  1. Q
  1. ;
  1. ;==========================================
  1. SLL(FILENUM,IEN,PACKLIST) ;Reminder location lists.
  1. N CSTEXL,IND,ROUTINE
  1. D SGEN(FILENUM,IEN,.PACKLIST)
  1. ;If CREDIT STOPS TO EXCLUDE (LIST) has been used put it on the packing
  1. ;list.
  1. S IND=0
  1. F S IND=+$O(^PXRMD(810.9,IEN,40.7,IND)) Q:IND=0 D
  1. . S CSTEXL=$G(^PXRMD(810.9,IEN,40.7,IND,2))
  1. . I CSTEXL="" Q
  1. . S ROUTINE=$$GETSRTN(810.9)_"(810.9,CSTEXL,.PACKLIST)"
  1. . D @ROUTINE
  1. ;Save information about hospital locations which are non-transportable.
  1. I $D(^PXRMD(810.9,IEN,44))>1 D NTHLOC^PXRMEXFI(IEN,"LOCATION LIST")
  1. Q
  1. ;
  1. ;==========================================
  1. SLR(FILENUM,IEN,PACKLIST) ;Reminder list rules.
  1. N IND,LR,RDEF,RTERM,ROUTINE,TEMP
  1. D SGEN(FILENUM,IEN,.PACKLIST)
  1. S TEMP=^PXRM(810.4,IEN,0)
  1. S RTERM=$P(TEMP,U,7)
  1. I RTERM'="" D
  1. . S ROUTINE=$$GETSRTN(811.5)_"(811.5,RTERM,.PACKLIST)"
  1. . D @ROUTINE
  1. S RDEF=$P(TEMP,U,10)
  1. I RDEF'="" D
  1. . S ROUTINE=$$GETSRTN(811.9)_"(811.9,RDEF,.PACKLIST,1)"
  1. . D @ROUTINE
  1. ;If there is a sequence save the list rules.
  1. I '$D(^PXRM(810.4,IEN,30)) Q
  1. S ROUTINE=$$GETSRTN(810.4)_"(810.4,LR,.PACKLIST)"
  1. S IND=0
  1. F S IND=+$O(^PXRM(810.4,IEN,30,IND)) Q:IND=0 D
  1. . S LR=$P(^PXRM(810.4,IEN,30,IND,0),U,2)
  1. . D @ROUTINE
  1. Q
  1. ;
  1. ;==========================================
  1. SLT(FILENUM,IEN,PACKLIST) ;Lab tests
  1. I +IEN'=IEN S IEN=$P(IEN,";",3)
  1. D SGEN(FILENUM,IEN,.PACKLIST)
  1. Q
  1. ;
  1. ;==========================================
  1. SODIALOG(FILENUM,IEN,PACKLIST) ;Order dialogs.
  1. D SGEN(FILENUM,IEN,.PACKLIST)
  1. ;DBIA 5446
  1. N CNT,OUTPUT,SUB,TYPE
  1. S CNT=0,SUB="ORDER DIALOG"
  1. S OUTPUT=$NA(^TMP($J,SUB,IEN))
  1. S TYPE=$P($G(^ORD(101.41,IEN,0)),U,4)
  1. D BEG^ORORDDSC(.OUTPUT,IEN,TYPE,.CNT)
  1. S CNT=CNT+1,^TMP($J,SUB,IEN,CNT)=$$REPEAT^XLFSTR("-",79)
  1. ;D EN^ORORDDSC(IEN,"ORDER DIALOG")
  1. Q
  1. ;
  1. ;==========================================
  1. SRCG(FILENUM,IEN,PACKLIST) ;Reminder counting groups.
  1. N IND,ROUTINE,TIEN
  1. D SGEN(FILENUM,IEN,.PACKLIST)
  1. ;Put terms on the pack list.
  1. S ROUTINE=$$GETSRTN(811.5)_"(811.5,TIEN,.PACKLIST)"
  1. S IND=0
  1. F S IND=+$O(^PXRM(810.8,IEN,10,IND)) Q:IND=0 D
  1. . S TIEN=$P(^PXRM(810.8,IEN,10,IND,0),U,2)
  1. . D @ROUTINE
  1. Q
  1. ;
  1. ;==========================================
  1. SRECR(FILENUM,IEN,PACKLIST) ;Reminder extract counting rule.
  1. N CGIEN,IND,ROUTINE,TIEN
  1. D SGEN(FILENUM,IEN,.PACKLIST)
  1. ;Put counting groups on the pack list.
  1. S ROUTINE=$$GETSRTN(810.8)_"(810.8,CGIEN,.PACKLIST)"
  1. S IND=0
  1. F S IND=+$O(^PXRM(810.7,IEN,10,IND)) Q:IND=0 D
  1. . S CGIEN=$P(^PXRM(810.7,IEN,10,IND,0),U,2)
  1. . D @ROUTINE
  1. Q
  1. ;
  1. ;==========================================
  1. SRT(FILENUM,TIEN,PACKLIST) ;Reminder terms.
  1. N FNUM,GBL,IEN,NF,ROUTINE,SPON
  1. N ITEM,NUM,RIEN
  1. D EXISTS(FILENUM,TIEN,.PACKLIST)
  1. D ADD(FILENUM,TIEN,.PACKLIST,.NF)
  1. ;Process the finding multiple.
  1. S GBL=""
  1. F S GBL=$O(^PXRMD(811.5,TIEN,20,"E",GBL)) Q:GBL="" D
  1. . S FNUM=$$GETFNUM(GBL)
  1. . I FNUM=811.4 D CHKCF("^PXRMD(811.5)",TIEN,GBL,.PACKLIST)
  1. . S ROUTINE=$$GETSRTN(FNUM)_"(FNUM,IEN,.PACKLIST)"
  1. . S IEN=""
  1. . F S IEN=$O(^PXRMD(811.5,TIEN,20,"E",GBL,IEN)) Q:IEN="" D @ROUTINE
  1. ;Sponsor
  1. S SPON=+$P(^PXRMD(811.5,TIEN,100),U,2)
  1. I SPON>0 D SGEN(811.6,SPON,.PACKLIST)
  1. Q
  1. ;
  1. ;==========================================
  1. SROC(FILENUM,ROCIEN,PACKLIST) ;Reminder Order Checks.
  1. ;packed order check structure up
  1. D SGENR(FILENUM,ROCIEN,.PACKLIST)
  1. N GBL,SUB,DRCL,FNUM,ITEM,OI,OLIST,RIEN,ROUTINE,TIEN,TLIST,WPNODE
  1. ;Process the pharmacy multiple.
  1. S ITEM=""
  1. F S ITEM=$O(^PXD(801,ROCIEN,1.5,"B",ITEM)) Q:ITEM="" D
  1. . S IEN=$P(ITEM,";"),GBL=$P(ITEM,";",2)
  1. . S FNUM=$$GETFNUM(GBL)
  1. . S ROUTINE=$$GETSRTN(FNUM)_"(FNUM,IEN,.PACKLIST)"
  1. . D @ROUTINE
  1. ;loop through rules and packed definitions or terms
  1. S SUB=0 F S SUB=$O(^PXD(801,ROCIEN,3,SUB)) Q:SUB'>0 D
  1. .S RIEN=$P($G(^PXD(801,ROCIEN,3,SUB,0)),U) Q:RIEN'>0
  1. .S ROUTINE=$$GETSRTN(801.1)_"(801.1,RIEN,.PACKLIST)"
  1. .D @ROUTINE
  1. Q
  1. ;
  1. ;==========================================
  1. SRULE(FILENUM,RULEIEN,PACKLIST) ;Reminder Order Check Rules.
  1. ;packed order check structure up
  1. D SGENR(FILENUM,RULEIEN,.PACKLIST)
  1. N OLIST,RIEN,ROUTINE,TIEN,TLIST
  1. I $D(^PXD(801.1,RULEIEN,3,4))>0 D
  1. .;search for TIU Objects
  1. .D TIUSRCH^PXRMEXU1("^PXD(801.1,",RULEIEN,",4",.OLIST,.TLIST)
  1. .I $D(OLIST)>0 D
  1. ..S ROUTINE=$$GETSRTN(8925.1)_"(8925.1,.OLIST,.PACKLIST)"
  1. ..D @ROUTINE K OLIST
  1. .K TLIST
  1. .;packed term up only
  1. S TIEN=$P($G(^PXD(801.1,RULEIEN,2)),U) I TIEN>0 D Q
  1. .S ROUTINE=$$GETSRTN(811.5)_"(811.5,TIEN,.PACKLIST)"
  1. .D @ROUTINE
  1. ;packed definition up if defined
  1. S RIEN=$P($G(^PXD(801.1,RULEIEN,3)),U) I RIEN>0 D
  1. .S ROUTINE=$$GETSRTN(811.9)_"(811.9,RIEN,.PACKLIST,1)"
  1. .D @ROUTINE
  1. Q
  1. ;
  1. ;==========================================
  1. STIUOBJ(FILENUM,OLIST,PACKLIST) ;
  1. N ARY,CNT,HSO,IEN,NAME,ROUTINE,TEMP
  1. S CNT=0 F S CNT=$O(OLIST(CNT)) Q:CNT'>0 D
  1. . S NAME=OLIST(CNT)
  1. . ;DBIA 5447
  1. . S IEN=$$OBJBYNAM^TIUCHECK(.ARY,NAME) I IEN=-1 Q
  1. .;Do not ship non TIU/HS Objects
  1. . I $G(ARY(IEN,9))'["S X=$$TIU^GMTSOBJ(" D Q
  1. .. D TIU^PXRMEXU5(IEN,.ARY,"TIU OBJECT")
  1. .. D SGEN(FILENUM,IEN,.PACKLIST)
  1. . D SGEN(FILENUM,IEN,.PACKLIST)
  1. . S TEMP=$P($G(ARY(IEN,9)),",",2)
  1. . S HSO=$P(TEMP,")")
  1. . S ROUTINE=$$GETSRTN(142.5)_"(142.5,.HSO,.PACKLIST)"
  1. . D @ROUTINE
  1. Q
  1. ;
  1. ;==========================================
  1. STIUTEMP(FILENUM,TLIST,PACKLIST) ;
  1. N CNT,IEN,NAME
  1. S CNT=0 F S CNT=$O(TLIST(CNT)) Q:CNT'>0 D
  1. .S NAME=TLIST(CNT)
  1. .S IEN=$O(^TIU(8927.1,"B",NAME,"")) Q:IEN'>0
  1. .D SGEN(FILENUM,IEN,.PACKLIST)
  1. Q
  1. ;