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