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

PXRMRPCA.m

Go to the documentation of this file.
  1. PXRMRPCA ; SLC/PJH - Functions returning REMINDER data ;02/10/2015
  1. ;;2.0;CLINICAL REMINDERS;**12,16,47**;Feb 04, 2005;Build 291
  1. Q
  1. ;
  1. ALL(ORY) ;All active reminders
  1. ;print name^ien
  1. N ARR,DATA,NAME,ORREM,OCNT,SUB,USAGE
  1. S ORREM=0
  1. F S ORREM=$O(^PXD(811.9,ORREM)) Q:'ORREM D
  1. .;Include only CPRS reminders
  1. .S USAGE=$P($G(^PXD(811.9,ORREM,100)),U,4)
  1. .I USAGE["L" Q
  1. .I USAGE["O" Q
  1. .I USAGE'["C",USAGE'["*" Q
  1. .S DATA=$G(^PXD(811.9,ORREM,0)) Q:DATA=""
  1. .;Skip inactive reminders
  1. .I $P(DATA,U,6) Q
  1. .;Skip reminders with no name
  1. .S NAME=$P(DATA,U,3) I NAME="" Q
  1. .;Sort by name
  1. .S ARR(NAME_U_ORREM)=""
  1. ; Build output arrray
  1. S SUB="",OCNT=0
  1. F S SUB=$O(ARR(SUB)) Q:SUB="" D
  1. .S OCNT=OCNT+1
  1. .S ORY(OCNT)=SUB
  1. Q
  1. ;
  1. APPL(ORY,ORPT,ORLOC) ;Applicable reminders for cover sheet
  1. ;format file 811.9 ien^reminder print name^date due^last occur^prty^due.
  1. N ORSRV,TMPLST,ERR,ORI,ORJ,ORIEN,ORTXT,ORX,ORLASTDT,ORDUEDT
  1. N ORDUE,ORPRI,ORSTA,PASS
  1. S ORJ=0
  1. S ORSRV=$$GET1^DIQ(200,DUZ,29)
  1. I ORLOC S PASS="USR^LOC.`"_$G(ORLOC)_"^SRV.`"_+$G(ORSRV)_"^DIV^SYS^PKG"
  1. I 'ORLOC S PASS="USR^SRV.`"_+$G(ORSRV)_"^DIV^SYS^PKG"
  1. D GETLST^XPAR(.TMPLST,PASS,"ORQQPX SEARCH ITEMS","Q",.ERR) ; DBIA #3076
  1. I ERR>0 S ORY(1)=U_"Error: "_$P(ERR,U,2) Q
  1. D AVAL(.TMPLST,2) ;Evaluate reminders
  1. Q
  1. ;
  1. ALIST(ORY,ORPT,LIST) ;Evaluate specific reminders
  1. N ORSRV,ORI,ORJ,ORIEN,ORTXT,ORX,ORLASTDT,ORDUEDT,ORLOC
  1. N ORDUE,ORPRI,ORSTA
  1. S ORJ=0
  1. D AVAL(.LIST,1)
  1. Q
  1. ;
  1. AVAL(ARRAY,POS) ;Evaluate array of reminders
  1. S ORI=0 F S ORI=$O(ARRAY(ORI)) Q:'ORI D
  1. .S ORIEN=$P(ARRAY(ORI),U,POS)
  1. .K ^TMP("PXRHM",$J)
  1. . I $$INACTIVE^PXRM(ORIEN) Q
  1. .;Evaluate reminder
  1. .D MAIN^PXRM(ORPT,ORIEN,1,1)
  1. .;Not applicable is default
  1. .S ORDUE=2 D Q:ORTXT=""
  1. ..S ORTXT="",ORTXT=$O(^TMP("PXRHM",$J,ORIEN,ORTXT)) Q:ORTXT=""
  1. ..;Determine status
  1. ..S ORX=^TMP("PXRHM",$J,ORIEN,ORTXT) Q:ORX=""
  1. ..S ORSTA=$P(ORX,U)
  1. ..;Ignore reminders that are not applicable
  1. ..I (ORSTA=" ")!(ORSTA["NEVER")!(ORSTA="N/A") Q
  1. ..;Differentiate due and applicable
  1. ..S ORDUE=0 I ORSTA["DUE" S ORDUE=1
  1. ..I ORSTA["ERROR" S ORDUE=3
  1. ..I ORSTA["CNBD" S ORDUE=4
  1. ..;Get next due and last done dates
  1. ..S ORDUEDT=$P(ORX,U,2),ORLASTDT=$P(ORX,U,3)
  1. ..S ORLASTDT=$S(+$G(ORLASTDT)>0:ORLASTDT,1:"") ;null if not a date
  1. ..;Reminder priority
  1. ..S ORPRI=$P($G(^PXD(811.9,ORIEN,0)),U,10)
  1. ..;Default is 2 for medium
  1. ..I ORPRI="" S ORPRI=2
  1. ..S ORJ=ORJ+1
  1. ..S ORY(ORJ)=ORIEN_U_ORTXT_U_ORDUEDT_U_ORLASTDT_U_ORPRI_U_ORDUE_U_$$DLG(ORIEN)_U_U_U_U_$$DLGWIPE(ORIEN)
  1. .;Save not applicables also (IF a valid reminder)
  1. .I ORDUE=2 D
  1. ..S ORJ=ORJ+1
  1. ..S ORY(ORJ)=ORIEN_U_ORTXT_U_U_U_U_ORDUE_U_$$DLG(ORIEN)_U_U_U_U_$$DLGWIPE(ORIEN)
  1. K ^TMP("PXRHM",$J)
  1. Q
  1. ;
  1. CATEGORY(ORY,ORPT,ORLOC) ;Reminder Categories
  1. ;type^name^ien^parent^child^etc
  1. N ERR,IC,ORSRV,PASS,TEMPLST
  1. ;Get user's service
  1. ;S ORSRV=$G(^VA(200,DUZ,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U)
  1. S ORSRV=$$GET1^DIQ(200,DUZ,29)
  1. ;Build list of locations and services required
  1. I ORLOC S PASS="USR^LOC.`"_$G(ORLOC)_"^SRV.`"_+$G(ORSRV)_"^DIV^SYS^PKG"
  1. I 'ORLOC S PASS="USR^SRV.`"_+$G(ORSRV)_"^DIV^SYS^PKG"
  1. ;
  1. ;Get list of categories from GUI parameters file
  1. D GETLST^XPAR(.TMPLST,PASS,"PXRM CPRS LOOKUP CATEGORIES","Q",.ERR)
  1. ;If error return error type
  1. I ERR>0 S ORY(1)=U_"Error: "_$P(ERR,U,2) Q
  1. ;
  1. ;For each category build tree of reminders/subcategories
  1. N CNT,LEVEL,ORCAT,UNIQ
  1. S CNT="",IC=0,LEVEL=0,UNIQ=0
  1. ;For each category in 'PXRM CPRS LOOKUP CATEGORIES'
  1. F S CNT=$O(TMPLST(CNT)) Q:'CNT D
  1. .;Get category ien
  1. .S ORCAT=$P(TMPLST(CNT),U,2)
  1. .;Update unique number
  1. .S UNIQ=UNIQ+1
  1. .;Add category and associated reminders/subcategories to output array
  1. .D GETLST(0,ORCAT,0,UNIQ)
  1. Q
  1. ;
  1. DLG(REM) ;Dialog check
  1. N DATA,DIEN,DOK
  1. S DIEN=$P($G(^PXD(811.9,REM,51)),U) Q:'DIEN 0
  1. S DATA=$G(^PXRMD(801.41,DIEN,0))
  1. I $P(DATA,U,4)="R",+$P(DATA,U,3)=0 Q 1
  1. Q 0
  1. ;
  1. DLGWIPE(REM) ;Dialog check
  1. N DATA,DIEN,DOK
  1. S DIEN=$P($G(^PXD(811.9,REM,51)),U) Q:'DIEN 0
  1. I $P($G(^PXRMD(801.41,DIEN,0)),U,17)=1 Q 1
  1. Q 0
  1. ;
  1. GETLST(D0,D1,LEVEL,PARENT) ;Add to output array
  1. N DATA,NAME,ORREM,ORSCAT,PCAT,SEQ,SUB,TEMP,USAGE
  1. ;Get category ien if this is a sub-category
  1. S PCAT=0 I LEVEL>0 D Q:ORSCAT="" S UNIQ=UNIQ+1,PARENT=UNIQ
  1. .S ORSCAT=$P($G(^PXRMD(811.7,D0,10,D1,0)),U),PCAT=PARENT
  1. ;Otherwise use passed ien
  1. I LEVEL=0 S ORSCAT=D1
  1. ;Get category name
  1. S NAME=$G(^PXRMD(811.7,ORSCAT,0)) I NAME="" Q
  1. ;
  1. ;Create category entry in output array
  1. ;unique number^type^name^parent^reminder ien
  1. ;
  1. S IC=IC+1,ORY(IC)=PARENT_U_"C"_U_NAME_U_PCAT_U
  1. ;Increment tab
  1. S LEVEL=LEVEL+1
  1. ;
  1. ;Sort Reminders from this category into display sequence
  1. S SUB=0 K TEMP
  1. F S SUB=$O(^PXRMD(811.7,ORSCAT,2,SUB)) Q:SUB="" D
  1. .S DATA=$G(^PXRMD(811.7,ORSCAT,2,SUB,0)) Q:DATA=""
  1. .S ORREM=$P(DATA,U) Q:ORREM=""
  1. .S SEQ=$P(DATA,U,2)_0
  1. .;Skip inactive reminders
  1. .S DATA=$G(^PXD(811.9,ORREM,0)) Q:DATA="" Q:$P(DATA,U,6)
  1. .;Include only CPRS reminders
  1. .S USAGE=$P($G(^PXD(811.9,ORREM,100)),U,4) I USAGE'["C",USAGE'["*" Q
  1. .I USAGE["L"!(USAGE["O") Q
  1. .S NAME=$P(DATA,U) I NAME="" S NAME="Unknown"
  1. .;or printname
  1. .S NAME=$P(DATA,U,3)
  1. .S TEMP(SEQ)=NAME_U_ORREM
  1. ;
  1. ;Re-save reminders in output array for display
  1. ;unique number^type^name^parent^reminder ien
  1. ;
  1. S SEQ=""
  1. F S SEQ=$O(TEMP(SEQ)) Q:SEQ="" D
  1. .S NAME=$P(TEMP(SEQ),U),ORREM=$P(TEMP(SEQ),U,2)
  1. .S UNIQ=UNIQ+1
  1. .S IC=IC+1,ORY(IC)=UNIQ_U_"R"_U_NAME_U_PARENT_U_ORREM_U_$$DLG(ORREM)
  1. ;
  1. ;Sort Sub-Categories for this category into display order
  1. S SUB=0 K TEMP
  1. F S SUB=$O(^PXRMD(811.7,ORSCAT,10,SUB)) Q:SUB="" D
  1. .S DATA=$G(^PXRMD(811.7,ORSCAT,10,SUB,0)) Q:DATA=""
  1. .S SEQ=$P(DATA,U,2),TEMP(SEQ)=SUB
  1. ;
  1. ;Process sub-sub categories in the same manner
  1. S SEQ=""
  1. F S SEQ=$O(TEMP(SEQ)) Q:SEQ="" D
  1. .S SUB=TEMP(SEQ)
  1. .D GETLST(ORSCAT,SUB,LEVEL,PARENT)
  1. Q
  1. ;
  1. LIST(ORY,ORPT,ORLOC) ;Reminders for this patient location (not evaluated)
  1. ;format file 811.9 ien
  1. N ORSRV,TMPLST,ERR,ORI,ORJ,ORIEN,ORTXT,ORX,ORLASTDT,ORDUEDT
  1. N CNT,ORIEN,ORDUE,ORPRI,ORSTA,PASS,SUB
  1. S ORJ=0
  1. ;
  1. S ORSRV=$$GET1^DIQ(200,DUZ,29)
  1. I ORLOC S PASS="USR^LOC.`"_$G(ORLOC)_"^SRV.`"_+$G(ORSRV)_"^DIV^SYS^PKG"
  1. I 'ORLOC S PASS="USR^SRV.`"_+$G(ORSRV)_"^DIV^SYS^PKG"
  1. D GETLST^XPAR(.TMPLST,PASS,"ORQQPX SEARCH ITEMS","Q",.ERR) ; DBIA #3076
  1. I ERR>0 S ORY(1)=U_"Error: "_$P(ERR,U,2) Q
  1. ;
  1. S CNT=0,SUB=""
  1. F S SUB=$O(TMPLST(SUB)) Q:'SUB D
  1. .S ORIEN=$P(TMPLST(SUB),U,2) Q:'ORIEN Q:'$D(^PXD(811.9,ORIEN,0))
  1. .S CNT=CNT+1,ORY(CNT)=ORIEN
  1. Q
  1. ;
  1. REMDET(ORY,ORPT,ORIEN) ;return detail for a pt's clinical reminder
  1. ; ORY - return array
  1. ; ORPT - patient DFN
  1. ; ORIEN - clinical reminder (811.9 ien)
  1. N NL
  1. K ^TMP("PXRHM",$J)
  1. D MAIN^PXRM(ORPT,ORIEN,5,1) ; 5 returns all reminder info
  1. S NL=0
  1. D FMTOUT^PXRMFMTO("PXRHM",.NL,.ORY)
  1. K ^TMP("PXRHM",$J)
  1. Q
  1. ;
  1. WEB(ORY,ORRM) ;web page call
  1. ;web site description^address
  1. N ADDR,CNT,DATA,DESC,LINE,SUB,TITLE,TXT,UNIQ
  1. S DESC="",CNT=0,UNIQ=0
  1. ;Get the reminder specific web sites in alpha order
  1. I ORRM]"" D
  1. .F S DESC=$O(^PXD(811.9,ORRM,50,"B",DESC)) Q:DESC="" D
  1. ..S SUB=0
  1. ..F S SUB=$O(^PXD(811.9,ORRM,50,"B",DESC,SUB)) Q:'SUB D
  1. ...S ADDR=$P($G(^PXD(811.9,ORRM,50,SUB,0)),U) Q:ADDR=""
  1. ...S TITLE=$P($G(^PXD(811.9,ORRM,50,SUB,0)),U,2)
  1. ...S UNIQ=UNIQ+1,CNT=CNT+1,ORY(CNT)=1_U_UNIQ_U_ADDR_U_TITLE,LINE=0
  1. ...F S LINE=$O(^PXD(811.9,ORRM,50,SUB,1,LINE)) Q:'LINE D
  1. ....S TXT=$G(^PXD(811.9,ORRM,50,SUB,1,LINE,0)) Q:TXT=""
  1. ....S CNT=CNT+1,ORY(CNT)=2_U_UNIQ_U_TXT
  1. ;Get the general web sites in alpha order
  1. F S DESC=$O(^PXRM(800,1,1,"B",DESC)) Q:DESC="" D
  1. .S SUB=0
  1. .F S SUB=$O(^PXRM(800,1,1,"B",DESC,SUB)) Q:'SUB D
  1. ..S ADDR=$P($G(^PXRM(800,1,1,SUB,0)),U) Q:ADDR=""
  1. ..S TITLE=$P($G(^PXRM(800,1,1,SUB,0)),U,2)
  1. ..S UNIQ=UNIQ+1,CNT=CNT+1,ORY(CNT)=1_U_UNIQ_U_ADDR_U_TITLE,LINE=0
  1. ..F S LINE=$O(^PXRM(800,1,1,SUB,1,LINE)) Q:'LINE D
  1. ...S TXT=$G(^PXRM(800,1,1,SUB,1,LINE,0)) Q:TXT=""
  1. ...S CNT=CNT+1,ORY(CNT)=2_U_UNIQ_U_TXT
  1. Q