ORQQPX ; SLC/JM - PCE and Reminder routines ;10/16/2019
;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,184,187,190,226,377**;Dec 17, 1997;Build 582
Q
;
IMMLIST(ORY,ORPT,ORSORT) ;return pt's immunization list:
;id^name^date/time^reaction^inverse d/t
I $L($T(IMMUN^PXRHS03))<1 S ORY(1)="^Immunizations not available." Q
K ^TMP("PXI",$J)
D IMMUN^PXRHS03(ORPT,$G(ORSORT))
N ORI,IMM,IVDT,IEN,X
S ORI=0,IMM="",IVDT="",IEN=0
F S IMM=$O(^TMP("PXI",$J,IMM)) Q:IMM="" D
.F S IVDT=$O(^TMP("PXI",$J,IMM,IVDT)) Q:IVDT="" D
..F S IEN=$O(^TMP("PXI",$J,IMM,IVDT,IEN)) Q:IEN<1 D
...S ORI=ORI+1,X=$G(^TMP("PXI",$J,IMM,IVDT,IEN,0)) Q:'$L(X)
...S ORY(ORI)=IEN_U_IMM_U_$P(X,U,3)
...I $P(X,U,7)=1 S ORY(ORI)=ORY(ORI)_U_$P(X,U,6)_U_IVDT
...E S ORY(ORI)=ORY(ORI)_U_U_IVDT
S:+$G(ORY(1))<1 ORY(1)="^No immunizations found.^2900101^^9999999"
K ^TMP("PXI",$J)
Q
;
DETAIL(ORY,IMM) ; return detailed information for an immunization
S ORY(1)="Detailed information on immunizations is not available."
Q
;
REMIND(ORY,ORPT) ;return pt's currently due PCE clinical reminders
; in the format file 811.9 ien^reminder print name^date due^last occur.
N ORTMPLST,ORI,ORJ,ORIEN,ORTXT,ORX,ORLASTDT,ORDUEDT,ORLOC
S ORJ=0
;
;get patient's location flag (INPATIENT ONLY - outpt locations cannot be
;reliably determined, and many simultaneous outpt locations can occur):
I +$G(ORPT)>0 D
.N DFN S DFN=ORPT,VA200="" D OERR^VADPT
.I +$G(VAIN(4))>0 S ORLOC=+$G(^DIC(42,+$G(VAIN(4)),44))
.K VA200,VAIN
;
D REMLIST(.ORTMPLST,$G(ORLOC))
;D GETLST^XPAR(.ORTMPLST,"USR^LOC.`"_$G(ORLOC)_"^SRV.`"_+$G(ORSRV)_"^DIV^SYS^PKG","ORQQPX SEARCH ITEMS","Q",.ORERR)
;I ORERR>0 S ORY(1)=U_"Error: "_$P(ORERR,U,2) Q
D AVAL^PXRMRPCA(.ORTMPLST,2)
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) ; 5 returns all reminder info
N CR,I,J,ORTXT S I=1
S ORTXT="",ORTXT=$O(^TMP("PXRHM",$J,ORIEN,ORTXT)) Q:ORTXT="" D
.S J=0 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
;
NEWACTIV(ORY) ;Return true if Interactive Reminders are active
S ORY=0
I $T(APPL^PXRMRPCA)'="",+$G(DUZ) D
. N SRV
. S SRV=$$GET1^DIQ(200,DUZ,29,"I")
. S ORY=$$GET^XPAR(DUZ_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","PXRM GUI REMINDERS ACTIVE",1,"Q")
. I +ORY S ORY=1
. E S ORY=0
Q
;
HISTLOC(LST) ;Returns a list of historical locations
N IDX,PTR,LINE,NAME
K ^TMP("OR",$J,"LOC")
S LST=$NA(^TMP("OR",$J,"LOC"))
S (LINE,IDX)=0
F S IDX=$O(^AUTTLOC(IDX)) Q:'IDX D
.S PTR=+$G(^AUTTLOC(IDX,0))
.I +PTR D
..S NAME=$$GET1^DIQ(4,PTR,.01,"I")
..I NAME'="" D
...S LINE=LINE+1
...S ^TMP("OR",$J,"LOC",LINE)=PTR_U_NAME
Q
;
GETFLDRS(ORFLDRS) ;Return Visible Reminder Folders
; Codes: D=Due, A=Applicable, N=Not Applicable, E=Evaluated, O=Other
N SRV,ORERR,ORTMP
S SRV=$$GET1^DIQ(200,DUZ,29,"I")
D GETLST^XPAR(.ORTMP,"USR^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORQQPX REMINDER FOLDERS","Q",.ORERR)
I +ORTMP S ORFLDRS=$P($G(ORTMP(1)),U,2)
E S ORFLDRS="DAO"
Q
;
SETFLDRS(ORY,ORFLDRS) ;Sets Visible Reminder Folders for the current user
N ORERR
D EN^XPAR(DUZ_";VA(200,","ORQQPX REMINDER FOLDERS",1,ORFLDRS,.ORERR)
S ORY=1
Q
;
GETDEFOL(ORDEFLOC) ;Return Default Outside Locations
N SRV,ORERR
S SRV=$$GET1^DIQ(200,DUZ,29,"I")
D GETLST^XPAR(.ORDEFLOC,"USR^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORQQPX DEFAULT LOCATIONS","Q",.ORERR)
Q
;
INSCURS(ORY) ; Returns status of ORQQPX REMINDER TEXT AT CURSOR
N SRV,ORERR,ORTMP
S ORY=0,SRV=$$GET1^DIQ(200,DUZ,29,"I")
D GETLST^XPAR(.ORTMP,"USR^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORQQPX REMINDER TEXT AT CURSOR","Q",.ORERR)
I +ORTMP S ORY=$P($G(ORTMP(1)),U,2)
Q
;
NEWCVOK(ORY) ; Returns status of
N SRV,ORERR,ORTMP
S ORY=0,SRV=$$GET1^DIQ(200,DUZ,29,"I")
D GETLST^XPAR(.ORTMP,"USR^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORQQPX NEW REMINDER PARAMS","Q",.ORERR)
I +ORTMP S ORY=$P($G(ORTMP(1)),U,2)
Q
;
ADDNAME(ORX) ; Add Reminder or Category Name as 3rd piece
N CAT,IEN
S CAT=$E($P(ORX,U,2),2)
S IEN=$E($P(ORX,U,2),3,99)
I +IEN D
.I CAT="R" S $P(ORX,U,3)=$P($G(^PXD(811.9,IEN,0)),U,3)
.I CAT="C" S $P(ORX,U,3)=$P($G(^PXRMD(811.7,IEN,0)),U)
Q ORX
;
REMACCUM(ORY,LVL,TYP,SORT,CLASS) ; Accumulates ORTMP into ORY
; Format of entries in ORQQPX COVER SHEET REMINDERS:
; L:Lock;R:Remove;N:Normal / C:Category;R:Reminder / Cat or Rem IEN
N IDX,I,J,K,M,FOUND,ORERR,ORTMP,FLAG,IEN
N FFLAG,FIEN,OUT,P2,ADD,DOADD,CODE
I LVL="CLASS" D I 1
.N ORLST,ORCLS,ORCLSPRM,ORWP
.S ORCLSPRM="ORQQPX COVER SHEET REM CLASSES"
.D GETLST^XPAR(.ORLST,"SYS",ORCLSPRM,"Q",.ORERR)
.S I=0,M=0,CLASS=$G(CLASS)
.F S I=$O(ORLST(I)) Q:'I D
..S ORCLS=$P(ORLST(I),U,1)
..I +CLASS S ADD=(ORCLS=+CLASS) I 1
..E S ADD=$$ISA^USRLM(DUZ,ORCLS,.ORERR)
..I +ADD D
...D GETWP^XPAR(.ORWP,"SYS",ORCLSPRM,ORCLS,.ORERR)
...S K=0
...F S K=$O(ORWP(K)) Q:'K D
....S M=M+1
....S J=$P(ORWP(K,0),";",1)
....S ORTMP(M)=J_U_$P(ORWP(K,0),";",2)
E D GETLST^XPAR(.ORTMP,LVL,"ORQQPX COVER SHEET REMINDERS",TYP,.ORERR)
S I=0,IDX=$O(ORY(999999),-1)+1,ADD=(SORT="")
F S I=$O(ORTMP(I)) Q:'I D
.S (FOUND,J)=0,P2=$P(ORTMP(I),U,2)
.S FLAG=$E(P2),IEN=$E(P2,2,999)
.I ADD S DOADD=1
.E D
..S DOADD=0
..F S J=$O(ORY(J)) Q:'J D Q:FOUND
...S P2=$P(ORY(J),U,2)
...S FIEN=$E(P2,2,999)
...I FIEN=IEN S FOUND=J,FFLAG=$E(P2)
..I FOUND D I 1
...I FLAG="R",FFLAG'="L" K ORY(FOUND)
...I FLAG'=FFLAG,(FLAG_FFLAG)["L" S $E(P2)="L",$P(ORY(FOUND),U,2)=P2
..E I (FLAG'="R") S DOADD=1
.I DOADD D
..S OUT(IDX)=ORTMP(I)
..S $P(OUT(IDX),U)=$P(OUT(IDX),U)_SORT
..I SORT="" S OUT(IDX)=$$ADDNAME(OUT(IDX))
..S IDX=IDX+1
M ORY=OUT
Q
;
ADDREM(ORY,IDX,IEN) ; Add Reminder to ORY list
I $D(ORY("B",IEN)) Q ; See if it's in the list
I '$D(^PXD(811.9,IEN)) Q ; Check if Exists
I $P($G(^PXD(811.9,IEN,0)),U,6)'="" Q ; Check if Active
;Check to see if the reminder is assigned to CPRS
N USAGE
S USAGE=$P($G(^PXD(811.9,IEN,100)),U,4)
;If the Usage is List or Order Check skip it.
I (USAGE["L")!(USAGE["O") Q
;If the Usage is not C or * skip it.
I USAGE'["C",USAGE'="*" Q
S ORY(IDX)=IDX_U_IEN
S ORY("B",IEN)=""
Q
;
ADDCAT(ORY,IDX,IEN) ; Add Category Reminders to ORY list
N ORREM,I,IDX2,NREM
D CATREM^PXRMAPI0(IEN,.ORREM)
S I=0
F S I=$O(ORREM(I)) Q:'I D
. S IDX2="00000"_I
. S IDX2=$E(IDX2,$L(IDX2)-5,99)
. D ADDREM(.ORY,+(IDX_"."_IDX2),$P(ORREM(I),U,1))
Q
;
REMLIST(ORY,LOC) ;Returns a list of all cover sheet reminders
N SRV,I,J,ORLST,CODE,IDX,IEN,NEWP
S SRV=$$GET1^DIQ(200,DUZ,29,"I")
D NEWCVOK(.NEWP)
I 'NEWP D Q
. N OLDLIST,RESULT
. D GETLST^XPAR(.OLDLIST,"USR^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORQQPX SEARCH ITEMS","Q",.ORERR) Q
. S I=0
. F S I=$O(OLDLIST(I)) Q:'I D
.. S IDX=$P(OLDLIST(I),U,1)
.. F Q:'$D(RESULT(IDX)) S IDX=IDX+1
.. S IEN=$P(OLDLIST(I),U,2)
.. D ADDREM(.RESULT,IDX,IEN)
. K RESULT("B")
;
D REMACCUM(.ORLST,"PKG","Q",1000)
D REMACCUM(.ORLST,"SYS","Q",2000)
D REMACCUM(.ORLST,"DIV","Q",3000)
I +SRV D REMACCUM(.ORLST,"SRV.`"_+$G(SRV),"Q",4000)
I +LOC D REMACCUM(.ORLST,"LOC.`"_+$G(LOC),"Q",5000)
D REMACCUM(.ORLST,"CLASS","Q",6000)
D REMACCUM(.ORLST,"USR","Q",7000)
S I=0
F S I=$O(ORLST(I)) Q:'I D
.S IDX=$P(ORLST(I),U,1)
.F Q:'$D(ORY(IDX)) S IDX=IDX+1
.S CODE=$E($P(ORLST(I),U,2),2)
.S IEN=$E($P(ORLST(I),U,2),3,999)
.I CODE="R" D ADDREM(.ORY,IDX,IEN)
.I CODE="C" D ADDCAT(.ORY,IDX,IEN)
K ORY("B")
Q
;
LVREMLST(ORY,LVL,CLASS) ;Returns cover sheet reminders at a specified level
D REMACCUM(.ORY,LVL,"Q","",$G(CLASS))
Q
;
SAVELVL(ORY,LVL,CLASS,DATA) ;Save cover sheet reminders at a specified level
N ORERR,PARAM,I
I LVL="CLASS" D I 1
.S PARAM="ORQQPX COVER SHEET REM CLASSES"
.S LVL="SYS"
.D DEL^XPAR(LVL,PARAM,"`"_CLASS,.ORERR)
.D EN^XPAR(LVL,PARAM,"`"_CLASS,.DATA,.ORERR)
E D
.S PARAM="ORQQPX COVER SHEET REMINDERS"
.D NDEL^XPAR(LVL,PARAM,.ORERR)
.S I=0
.F S I=$O(DATA(I)) Q:'I D
..D EN^XPAR(LVL,PARAM,$P(DATA(I),U,1),$P(DATA(I),U,2),.ORERR)
S ORY=1
Q
;
GETLIST(ORY,ORLOC) ;Returns a list of all cover sheet reminders
N I
D REMLIST(.ORY,$G(ORLOC))
S I=0
F S I=$O(ORY(I)) Q:'I D
.S ORY(I)=$P(ORY(I),U,2)
Q
;
EVALCOVR(ORY,ORPT,ORLOC) ; Evaluate Cover Sheet Reminders
N ORTMP
D GETLIST(.ORTMP,$G(ORLOC))
D ALIST^ORQQPXRM(.ORY,ORPT,.ORTMP)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORQQPX 8663 printed Oct 16, 2024@18:34:20 Page 2
ORQQPX ; SLC/JM - PCE and Reminder routines ;10/16/2019
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,184,187,190,226,377**;Dec 17, 1997;Build 582
+2 QUIT
+3 ;
IMMLIST(ORY,ORPT,ORSORT) ;return pt's immunization list:
+1 ;id^name^date/time^reaction^inverse d/t
+2 IF $LENGTH($TEXT(IMMUN^PXRHS03))<1
SET ORY(1)="^Immunizations not available."
QUIT
+3 KILL ^TMP("PXI",$JOB)
+4 DO IMMUN^PXRHS03(ORPT,$GET(ORSORT))
+5 NEW ORI,IMM,IVDT,IEN,X
+6 SET ORI=0
SET IMM=""
SET IVDT=""
SET IEN=0
+7 FOR
SET IMM=$ORDER(^TMP("PXI",$JOB,IMM))
if IMM=""
QUIT
Begin DoDot:1
+8 FOR
SET IVDT=$ORDER(^TMP("PXI",$JOB,IMM,IVDT))
if IVDT=""
QUIT
Begin DoDot:2
+9 FOR
SET IEN=$ORDER(^TMP("PXI",$JOB,IMM,IVDT,IEN))
if IEN<1
QUIT
Begin DoDot:3
+10 SET ORI=ORI+1
SET X=$GET(^TMP("PXI",$JOB,IMM,IVDT,IEN,0))
if '$LENGTH(X)
QUIT
+11 SET ORY(ORI)=IEN_U_IMM_U_$PIECE(X,U,3)
+12 IF $PIECE(X,U,7)=1
SET ORY(ORI)=ORY(ORI)_U_$PIECE(X,U,6)_U_IVDT
+13 IF '$TEST
SET ORY(ORI)=ORY(ORI)_U_U_IVDT
End DoDot:3
End DoDot:2
End DoDot:1
+14 if +$GET(ORY(1))<1
SET ORY(1)="^No immunizations found.^2900101^^9999999"
+15 KILL ^TMP("PXI",$JOB)
+16 QUIT
+17 ;
DETAIL(ORY,IMM) ; return detailed information for an immunization
+1 SET ORY(1)="Detailed information on immunizations is not available."
+2 QUIT
+3 ;
REMIND(ORY,ORPT) ;return pt's currently due PCE clinical reminders
+1 ; in the format file 811.9 ien^reminder print name^date due^last occur.
+2 NEW ORTMPLST,ORI,ORJ,ORIEN,ORTXT,ORX,ORLASTDT,ORDUEDT,ORLOC
+3 SET ORJ=0
+4 ;
+5 ;get patient's location flag (INPATIENT ONLY - outpt locations cannot be
+6 ;reliably determined, and many simultaneous outpt locations can occur):
+7 IF +$GET(ORPT)>0
Begin DoDot:1
+8 NEW DFN
SET DFN=ORPT
SET VA200=""
DO OERR^VADPT
+9 IF +$GET(VAIN(4))>0
SET ORLOC=+$GET(^DIC(42,+$GET(VAIN(4)),44))
+10 KILL VA200,VAIN
End DoDot:1
+11 ;
+12 DO REMLIST(.ORTMPLST,$GET(ORLOC))
+13 ;D GETLST^XPAR(.ORTMPLST,"USR^LOC.`"_$G(ORLOC)_"^SRV.`"_+$G(ORSRV)_"^DIV^SYS^PKG","ORQQPX SEARCH ITEMS","Q",.ORERR)
+14 ;I ORERR>0 S ORY(1)=U_"Error: "_$P(ORERR,U,2) Q
+15 DO AVAL^PXRMRPCA(.ORTMPLST,2)
+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)
+6 NEW CR,I,J,ORTXT
SET I=1
+7 SET ORTXT=""
SET ORTXT=$ORDER(^TMP("PXRHM",$JOB,ORIEN,ORTXT))
if ORTXT=""
QUIT
Begin DoDot:1
+8 SET J=0
FOR
SET J=$ORDER(^TMP("PXRHM",$JOB,ORIEN,ORTXT,"TXT",J))
if J=""
QUIT
Begin DoDot:2
+9 SET ORY(I)=^TMP("PXRHM",$JOB,ORIEN,ORTXT,"TXT",J)
SET I=I+1
End DoDot:2
End DoDot:1
+10 KILL ^TMP("PXRHM",$JOB)
+11 QUIT
+12 ;
NEWACTIV(ORY) ;Return true if Interactive Reminders are active
+1 SET ORY=0
+2 IF $TEXT(APPL^PXRMRPCA)'=""
IF +$GET(DUZ)
Begin DoDot:1
+3 NEW SRV
+4 SET SRV=$$GET1^DIQ(200,DUZ,29,"I")
+5 SET ORY=$$GET^XPAR(DUZ_";VA(200,^SRV.`"_+$GET(SRV)_"^DIV^SYS","PXRM GUI REMINDERS ACTIVE",1,"Q")
+6 IF +ORY
SET ORY=1
+7 IF '$TEST
SET ORY=0
End DoDot:1
+8 QUIT
+9 ;
HISTLOC(LST) ;Returns a list of historical locations
+1 NEW IDX,PTR,LINE,NAME
+2 KILL ^TMP("OR",$JOB,"LOC")
+3 SET LST=$NAME(^TMP("OR",$JOB,"LOC"))
+4 SET (LINE,IDX)=0
+5 FOR
SET IDX=$ORDER(^AUTTLOC(IDX))
if 'IDX
QUIT
Begin DoDot:1
+6 SET PTR=+$GET(^AUTTLOC(IDX,0))
+7 IF +PTR
Begin DoDot:2
+8 SET NAME=$$GET1^DIQ(4,PTR,.01,"I")
+9 IF NAME'=""
Begin DoDot:3
+10 SET LINE=LINE+1
+11 SET ^TMP("OR",$JOB,"LOC",LINE)=PTR_U_NAME
End DoDot:3
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
GETFLDRS(ORFLDRS) ;Return Visible Reminder Folders
+1 ; Codes: D=Due, A=Applicable, N=Not Applicable, E=Evaluated, O=Other
+2 NEW SRV,ORERR,ORTMP
+3 SET SRV=$$GET1^DIQ(200,DUZ,29,"I")
+4 DO GETLST^XPAR(.ORTMP,"USR^SRV.`"_+$GET(SRV)_"^DIV^SYS^PKG","ORQQPX REMINDER FOLDERS","Q",.ORERR)
+5 IF +ORTMP
SET ORFLDRS=$PIECE($GET(ORTMP(1)),U,2)
+6 IF '$TEST
SET ORFLDRS="DAO"
+7 QUIT
+8 ;
SETFLDRS(ORY,ORFLDRS) ;Sets Visible Reminder Folders for the current user
+1 NEW ORERR
+2 DO EN^XPAR(DUZ_";VA(200,","ORQQPX REMINDER FOLDERS",1,ORFLDRS,.ORERR)
+3 SET ORY=1
+4 QUIT
+5 ;
GETDEFOL(ORDEFLOC) ;Return Default Outside Locations
+1 NEW SRV,ORERR
+2 SET SRV=$$GET1^DIQ(200,DUZ,29,"I")
+3 DO GETLST^XPAR(.ORDEFLOC,"USR^SRV.`"_+$GET(SRV)_"^DIV^SYS^PKG","ORQQPX DEFAULT LOCATIONS","Q",.ORERR)
+4 QUIT
+5 ;
INSCURS(ORY) ; Returns status of ORQQPX REMINDER TEXT AT CURSOR
+1 NEW SRV,ORERR,ORTMP
+2 SET ORY=0
SET SRV=$$GET1^DIQ(200,DUZ,29,"I")
+3 DO GETLST^XPAR(.ORTMP,"USR^SRV.`"_+$GET(SRV)_"^DIV^SYS^PKG","ORQQPX REMINDER TEXT AT CURSOR","Q",.ORERR)
+4 IF +ORTMP
SET ORY=$PIECE($GET(ORTMP(1)),U,2)
+5 QUIT
+6 ;
NEWCVOK(ORY) ; Returns status of
+1 NEW SRV,ORERR,ORTMP
+2 SET ORY=0
SET SRV=$$GET1^DIQ(200,DUZ,29,"I")
+3 DO GETLST^XPAR(.ORTMP,"USR^SRV.`"_+$GET(SRV)_"^DIV^SYS^PKG","ORQQPX NEW REMINDER PARAMS","Q",.ORERR)
+4 IF +ORTMP
SET ORY=$PIECE($GET(ORTMP(1)),U,2)
+5 QUIT
+6 ;
ADDNAME(ORX) ; Add Reminder or Category Name as 3rd piece
+1 NEW CAT,IEN
+2 SET CAT=$EXTRACT($PIECE(ORX,U,2),2)
+3 SET IEN=$EXTRACT($PIECE(ORX,U,2),3,99)
+4 IF +IEN
Begin DoDot:1
+5 IF CAT="R"
SET $PIECE(ORX,U,3)=$PIECE($GET(^PXD(811.9,IEN,0)),U,3)
+6 IF CAT="C"
SET $PIECE(ORX,U,3)=$PIECE($GET(^PXRMD(811.7,IEN,0)),U)
End DoDot:1
+7 QUIT ORX
+8 ;
REMACCUM(ORY,LVL,TYP,SORT,CLASS) ; Accumulates ORTMP into ORY
+1 ; Format of entries in ORQQPX COVER SHEET REMINDERS:
+2 ; L:Lock;R:Remove;N:Normal / C:Category;R:Reminder / Cat or Rem IEN
+3 NEW IDX,I,J,K,M,FOUND,ORERR,ORTMP,FLAG,IEN
+4 NEW FFLAG,FIEN,OUT,P2,ADD,DOADD,CODE
+5 IF LVL="CLASS"
Begin DoDot:1
+6 NEW ORLST,ORCLS,ORCLSPRM,ORWP
+7 SET ORCLSPRM="ORQQPX COVER SHEET REM CLASSES"
+8 DO GETLST^XPAR(.ORLST,"SYS",ORCLSPRM,"Q",.ORERR)
+9 SET I=0
SET M=0
SET CLASS=$GET(CLASS)
+10 FOR
SET I=$ORDER(ORLST(I))
if 'I
QUIT
Begin DoDot:2
+11 SET ORCLS=$PIECE(ORLST(I),U,1)
+12 IF +CLASS
SET ADD=(ORCLS=+CLASS)
IF 1
+13 IF '$TEST
SET ADD=$$ISA^USRLM(DUZ,ORCLS,.ORERR)
+14 IF +ADD
Begin DoDot:3
+15 DO GETWP^XPAR(.ORWP,"SYS",ORCLSPRM,ORCLS,.ORERR)
+16 SET K=0
+17 FOR
SET K=$ORDER(ORWP(K))
if 'K
QUIT
Begin DoDot:4
+18 SET M=M+1
+19 SET J=$PIECE(ORWP(K,0),";",1)
+20 SET ORTMP(M)=J_U_$PIECE(ORWP(K,0),";",2)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
IF 1
+21 IF '$TEST
DO GETLST^XPAR(.ORTMP,LVL,"ORQQPX COVER SHEET REMINDERS",TYP,.ORERR)
+22 SET I=0
SET IDX=$ORDER(ORY(999999),-1)+1
SET ADD=(SORT="")
+23 FOR
SET I=$ORDER(ORTMP(I))
if 'I
QUIT
Begin DoDot:1
+24 SET (FOUND,J)=0
SET P2=$PIECE(ORTMP(I),U,2)
+25 SET FLAG=$EXTRACT(P2)
SET IEN=$EXTRACT(P2,2,999)
+26 IF ADD
SET DOADD=1
+27 IF '$TEST
Begin DoDot:2
+28 SET DOADD=0
+29 FOR
SET J=$ORDER(ORY(J))
if 'J
QUIT
Begin DoDot:3
+30 SET P2=$PIECE(ORY(J),U,2)
+31 SET FIEN=$EXTRACT(P2,2,999)
+32 IF FIEN=IEN
SET FOUND=J
SET FFLAG=$EXTRACT(P2)
End DoDot:3
if FOUND
QUIT
+33 IF FOUND
Begin DoDot:3
+34 IF FLAG="R"
IF FFLAG'="L"
KILL ORY(FOUND)
+35 IF FLAG'=FFLAG
IF (FLAG_FFLAG)["L"
SET $EXTRACT(P2)="L"
SET $PIECE(ORY(FOUND),U,2)=P2
End DoDot:3
IF 1
+36 IF '$TEST
IF (FLAG'="R")
SET DOADD=1
End DoDot:2
+37 IF DOADD
Begin DoDot:2
+38 SET OUT(IDX)=ORTMP(I)
+39 SET $PIECE(OUT(IDX),U)=$PIECE(OUT(IDX),U)_SORT
+40 IF SORT=""
SET OUT(IDX)=$$ADDNAME(OUT(IDX))
+41 SET IDX=IDX+1
End DoDot:2
End DoDot:1
+42 MERGE ORY=OUT
+43 QUIT
+44 ;
ADDREM(ORY,IDX,IEN) ; Add Reminder to ORY list
+1 ; See if it's in the list
IF $DATA(ORY("B",IEN))
QUIT
+2 ; Check if Exists
IF '$DATA(^PXD(811.9,IEN))
QUIT
+3 ; Check if Active
IF $PIECE($GET(^PXD(811.9,IEN,0)),U,6)'=""
QUIT
+4 ;Check to see if the reminder is assigned to CPRS
+5 NEW USAGE
+6 SET USAGE=$PIECE($GET(^PXD(811.9,IEN,100)),U,4)
+7 ;If the Usage is List or Order Check skip it.
+8 IF (USAGE["L")!(USAGE["O")
QUIT
+9 ;If the Usage is not C or * skip it.
+10 IF USAGE'["C"
IF USAGE'="*"
QUIT
+11 SET ORY(IDX)=IDX_U_IEN
+12 SET ORY("B",IEN)=""
+13 QUIT
+14 ;
ADDCAT(ORY,IDX,IEN) ; Add Category Reminders to ORY list
+1 NEW ORREM,I,IDX2,NREM
+2 DO CATREM^PXRMAPI0(IEN,.ORREM)
+3 SET I=0
+4 FOR
SET I=$ORDER(ORREM(I))
if 'I
QUIT
Begin DoDot:1
+5 SET IDX2="00000"_I
+6 SET IDX2=$EXTRACT(IDX2,$LENGTH(IDX2)-5,99)
+7 DO ADDREM(.ORY,+(IDX_"."_IDX2),$PIECE(ORREM(I),U,1))
End DoDot:1
+8 QUIT
+9 ;
REMLIST(ORY,LOC) ;Returns a list of all cover sheet reminders
+1 NEW SRV,I,J,ORLST,CODE,IDX,IEN,NEWP
+2 SET SRV=$$GET1^DIQ(200,DUZ,29,"I")
+3 DO NEWCVOK(.NEWP)
+4 IF 'NEWP
Begin DoDot:1
+5 NEW OLDLIST,RESULT
+6 DO GETLST^XPAR(.OLDLIST,"USR^LOC.`"_$GET(LOC)_"^SRV.`"_+$GET(SRV)_"^DIV^SYS^PKG","ORQQPX SEARCH ITEMS","Q",.ORERR)
QUIT
+7 SET I=0
+8 FOR
SET I=$ORDER(OLDLIST(I))
if 'I
QUIT
Begin DoDot:2
+9 SET IDX=$PIECE(OLDLIST(I),U,1)
+10 FOR
if '$DATA(RESULT(IDX))
QUIT
SET IDX=IDX+1
+11 SET IEN=$PIECE(OLDLIST(I),U,2)
+12 DO ADDREM(.RESULT,IDX,IEN)
End DoDot:2
+13 KILL RESULT("B")
End DoDot:1
QUIT
+14 ;
+15 DO REMACCUM(.ORLST,"PKG","Q",1000)
+16 DO REMACCUM(.ORLST,"SYS","Q",2000)
+17 DO REMACCUM(.ORLST,"DIV","Q",3000)
+18 IF +SRV
DO REMACCUM(.ORLST,"SRV.`"_+$GET(SRV),"Q",4000)
+19 IF +LOC
DO REMACCUM(.ORLST,"LOC.`"_+$GET(LOC),"Q",5000)
+20 DO REMACCUM(.ORLST,"CLASS","Q",6000)
+21 DO REMACCUM(.ORLST,"USR","Q",7000)
+22 SET I=0
+23 FOR
SET I=$ORDER(ORLST(I))
if 'I
QUIT
Begin DoDot:1
+24 SET IDX=$PIECE(ORLST(I),U,1)
+25 FOR
if '$DATA(ORY(IDX))
QUIT
SET IDX=IDX+1
+26 SET CODE=$EXTRACT($PIECE(ORLST(I),U,2),2)
+27 SET IEN=$EXTRACT($PIECE(ORLST(I),U,2),3,999)
+28 IF CODE="R"
DO ADDREM(.ORY,IDX,IEN)
+29 IF CODE="C"
DO ADDCAT(.ORY,IDX,IEN)
End DoDot:1
+30 KILL ORY("B")
+31 QUIT
+32 ;
LVREMLST(ORY,LVL,CLASS) ;Returns cover sheet reminders at a specified level
+1 DO REMACCUM(.ORY,LVL,"Q","",$GET(CLASS))
+2 QUIT
+3 ;
SAVELVL(ORY,LVL,CLASS,DATA) ;Save cover sheet reminders at a specified level
+1 NEW ORERR,PARAM,I
+2 IF LVL="CLASS"
Begin DoDot:1
+3 SET PARAM="ORQQPX COVER SHEET REM CLASSES"
+4 SET LVL="SYS"
+5 DO DEL^XPAR(LVL,PARAM,"`"_CLASS,.ORERR)
+6 DO EN^XPAR(LVL,PARAM,"`"_CLASS,.DATA,.ORERR)
End DoDot:1
IF 1
+7 IF '$TEST
Begin DoDot:1
+8 SET PARAM="ORQQPX COVER SHEET REMINDERS"
+9 DO NDEL^XPAR(LVL,PARAM,.ORERR)
+10 SET I=0
+11 FOR
SET I=$ORDER(DATA(I))
if 'I
QUIT
Begin DoDot:2
+12 DO EN^XPAR(LVL,PARAM,$PIECE(DATA(I),U,1),$PIECE(DATA(I),U,2),.ORERR)
End DoDot:2
End DoDot:1
+13 SET ORY=1
+14 QUIT
+15 ;
GETLIST(ORY,ORLOC) ;Returns a list of all cover sheet reminders
+1 NEW I
+2 DO REMLIST(.ORY,$GET(ORLOC))
+3 SET I=0
+4 FOR
SET I=$ORDER(ORY(I))
if 'I
QUIT
Begin DoDot:1
+5 SET ORY(I)=$PIECE(ORY(I),U,2)
End DoDot:1
+6 QUIT
+7 ;
EVALCOVR(ORY,ORPT,ORLOC) ; Evaluate Cover Sheet Reminders
+1 NEW ORTMP
+2 DO GETLIST(.ORTMP,$GET(ORLOC))
+3 DO ALIST^ORQQPXRM(.ORY,ORPT,.ORTMP)
+4 QUIT
+5 ;
