- PXRMRPCA ; SLC/PJH - Functions returning REMINDER data ;02/10/2015
- ;;2.0;CLINICAL REMINDERS;**12,16,47**;Feb 04, 2005;Build 291
- 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)
- N NL
- K ^TMP("PXRHM",$J)
- D MAIN^PXRM(ORPT,ORIEN,5,1) ; 5 returns all reminder info
- S NL=0
- D FMTOUT^PXRMFMTO("PXRHM",.NL,.ORY)
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMRPCA 8060 printed Feb 18, 2025@23:15:16 Page 2
- PXRMRPCA ; SLC/PJH - Functions returning REMINDER data ;02/10/2015
- +1 ;;2.0;CLINICAL REMINDERS;**12,16,47**;Feb 04, 2005;Build 291
- +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 NEW NL
- +5 KILL ^TMP("PXRHM",$JOB)
- +6 ; 5 returns all reminder info
- DO MAIN^PXRM(ORPT,ORIEN,5,1)
- +7 SET NL=0
- +8 DO FMTOUT^PXRMFMTO("PXRHM",.NL,.ORY)
- +9 KILL ^TMP("PXRHM",$JOB)
- +10 QUIT
- +11 ;
- 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