PXRMCVRL ; SLC/JM/AGP - Reminder CPRS Code ;04/08/2019
;;2.0;CLINICAL REMINDERS;**53,45**;Feb 04, 2005;Build 566
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
;
NEWCVOK(RESULT,USER) ; Returns status of
N SRV,ERR,TMP
S RESULT=0,SRV=$$GET1^DIQ(200,USER,29,"I")
D GETLST^XPAR(.TMP,"USR.`"_USER_"^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORQQPX NEW REMINDER PARAMS","Q",.ERR)
I +TMP S RESULT=$P($G(TMP(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(RESULT,LVL,TYP,SORT,CLASS,USER) ; 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(USER,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(RESULT(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(RESULT(J)) Q:'J D Q:FOUND
...S P2=$P(RESULT(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 RESULT(FOUND)
...I FLAG'=FFLAG,(FLAG_FFLAG)["L" S $E(P2)="L",$P(RESULT(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 RESULT=OUT
Q
;
ADDREM(RESULT,IDX,IEN) ; Add Reminder to RESULT list
I $D(RESULT("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 RESULT(IDX)=IDX_U_IEN
S RESULT("B",IEN)=""
Q
;
ADDCAT(RESULT,IDX,IEN) ; Add Category Reminders to ORY list
N REM,I,IDX2,NREM
D CATREM^PXRMAPI0(IEN,.REM)
S I=0
F S I=$O(REM(I)) Q:'I D
. S IDX2="00000"_I
. S IDX2=$E(IDX2,$L(IDX2)-5,99)
. D ADDREM(.RESULT,+(IDX_"."_IDX2),$P(REM(I),U,1))
Q
;
REMLIST(RESULT,PERSON,LOC) ;Returns a list of all cover sheet reminders
N SRV,I,J,LST,CODE,IDX,IEN,NEWP,USER
S USER=$S(+$G(PERSON)>0:+$G(PERSON),1:DUZ)
S SRV=$$GET1^DIQ(200,USER,29,"I")
D NEWCVOK(.NEWP,USER)
I 'NEWP D Q
. N OLDLIST
. D GETLST^XPAR(.OLDLIST,"USR.`"_USER_"^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORQQPX SEARCH ITEMS","Q",.ORERR)
. 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(.LST,"PKG","Q",1000)
D REMACCUM(.LST,"SYS","Q",2000)
D REMACCUM(.LST,"DIV","Q",3000)
I +SRV D REMACCUM(.LST,"SRV.`"_+$G(SRV),"Q",4000)
I +LOC D REMACCUM(.LST,"LOC.`"_+$G(LOC),"Q",5000)
D REMACCUM(.LST,"CLASS","Q",6000,"",USER)
D REMACCUM(.LST,"USR.`"_USER,"Q",7000)
S I=0
F S I=$O(LST(I)) Q:'I D
.S IDX=$P(LST(I),U,1)
.F Q:'$D(RESULT(IDX)) S IDX=IDX+1
.S CODE=$E($P(LST(I),U,2),2)
.S IEN=$E($P(LST(I),U,2),3,999)
.I CODE="R" D ADDREM(.RESULT,IDX,IEN)
.I CODE="C" D ADDCAT(.RESULT,IDX,IEN)
K RESULT("B")
Q
;
LVREMLST(RESULT,LVL,CLASS) ;Returns cover sheet reminders at a specified level
D REMACCUM(.RESULT,LVL,"Q","",$G(CLASS))
Q
;
GETLVRD(RESULT,LVL,CLASS) ;
N CAT,CINC,DIEN,IEN,INC,REMLIST,RIEN,REM,TEMP
D LVREMLST(.REMLIST,LVL,$G(CLASS))
S INC=0 F S INC=$O(REMLIST(INC)) Q:INC'>0 D
. S TEMP=$P($G(REMLIST(INC)),U,2) I TEMP="" Q
. I $E(TEMP)="R" Q
. I $E(TEMP,2)="C" D
.. S CAT=$E(TEMP,3,$L(TEMP))
.. D CATREM^PXRMAPI0(CAT,.REM)
.. S CINC=0 F S CINC=$O(REM(CINC)) Q:CINC'>0 D
... S IEN=$G(REM(CINC)) Q:IEN'>0
... S DIEN=+$G(^PXD(811.9,IEN,51)) Q:DIEN'>0
... S RESULT("REMINDER",DIEN)=""
. S IEN=$E(TEMP,3,$L(TEMP))
. S DIEN=+$G(^PXD(811.9,IEN,51)) Q:DIEN'>0
. S RESULT("REMINDER",DIEN)=""
Q
;
GETDLIST(RESULT,USER,LOC) ;
;get coversheet reminders list.
N IEN,NODE,NUM,REMLIST
D GETLIST(.REMLIST,USER,$G(LOC))
S NUM=0 F S NUM=$O(REMLIST(NUM)) Q:NUM'>0 D
.S IEN=+$G(REMLIST(NUM)) I IEN'>0 Q
.I +$G(^PXD(811.9,IEN,51))>0 S RESULT("REMINDER",+$G(^PXD(811.9,IEN,51)))=""
Q
;
GETTDLST(RESULT) ;
;get TIU template reminder dialogs list.
N IEN,NODE,NUM,REMLIST
S IEN=0 F S IEN=$O(^TIU(8927,IEN)) Q:IEN'>0 D
.S NODE=$G(^TIU(8927,IEN,0))
.I $P(NODE,U,15)>0 S RESULT("TEMPLATE",$P(NODE,U,15))=""
Q
;
GETLIST(RESULT,USER,LOC) ;Returns a list of all cover sheet reminders
N I
D REMLIST(.RESULT,USER,$G(LOC))
S I=0
F S I=$O(RESULT(I)) Q:'I D
.S RESULT(I)=$P(RESULT(I),U,2)
Q
;
EVALCOVR(RESULT,PT,LOC) ; Evaluate Cover Sheet Reminders
N ORTMP
D GETLIST(.ORTMP,$G(LOC))
D ALIST^ORQQPXRM(.RESULT,PT,.ORTMP)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMCVRL 5989 printed Apr 09, 2024@20:48:15 Page 2
PXRMCVRL ; SLC/JM/AGP - Reminder CPRS Code ;04/08/2019
+1 ;;2.0;CLINICAL REMINDERS;**53,45**;Feb 04, 2005;Build 566
+2 QUIT
+3 ;
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 ;
NEWCVOK(RESULT,USER) ; Returns status of
+1 NEW SRV,ERR,TMP
+2 SET RESULT=0
SET SRV=$$GET1^DIQ(200,USER,29,"I")
+3 DO GETLST^XPAR(.TMP,"USR.`"_USER_"^SRV.`"_+$GET(SRV)_"^DIV^SYS^PKG","ORQQPX NEW REMINDER PARAMS","Q",.ERR)
+4 IF +TMP
SET RESULT=$PIECE($GET(TMP(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(RESULT,LVL,TYP,SORT,CLASS,USER) ; 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(USER,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(RESULT(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(RESULT(J))
if 'J
QUIT
Begin DoDot:3
+30 SET P2=$PIECE(RESULT(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 RESULT(FOUND)
+35 IF FLAG'=FFLAG
IF (FLAG_FFLAG)["L"
SET $EXTRACT(P2)="L"
SET $PIECE(RESULT(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 RESULT=OUT
+43 QUIT
+44 ;
ADDREM(RESULT,IDX,IEN) ; Add Reminder to RESULT list
+1 ; See if it's in the list
IF $DATA(RESULT("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 RESULT(IDX)=IDX_U_IEN
+12 SET RESULT("B",IEN)=""
+13 QUIT
+14 ;
ADDCAT(RESULT,IDX,IEN) ; Add Category Reminders to ORY list
+1 NEW REM,I,IDX2,NREM
+2 DO CATREM^PXRMAPI0(IEN,.REM)
+3 SET I=0
+4 FOR
SET I=$ORDER(REM(I))
if 'I
QUIT
Begin DoDot:1
+5 SET IDX2="00000"_I
+6 SET IDX2=$EXTRACT(IDX2,$LENGTH(IDX2)-5,99)
+7 DO ADDREM(.RESULT,+(IDX_"."_IDX2),$PIECE(REM(I),U,1))
End DoDot:1
+8 QUIT
+9 ;
REMLIST(RESULT,PERSON,LOC) ;Returns a list of all cover sheet reminders
+1 NEW SRV,I,J,LST,CODE,IDX,IEN,NEWP,USER
+2 SET USER=$SELECT(+$GET(PERSON)>0:+$GET(PERSON),1:DUZ)
+3 SET SRV=$$GET1^DIQ(200,USER,29,"I")
+4 DO NEWCVOK(.NEWP,USER)
+5 IF 'NEWP
Begin DoDot:1
+6 NEW OLDLIST
+7 DO GETLST^XPAR(.OLDLIST,"USR.`"_USER_"^LOC.`"_$GET(LOC)_"^SRV.`"_+$GET(SRV)_"^DIV^SYS^PKG","ORQQPX SEARCH ITEMS","Q",.ORERR)
+8 SET I=0
+9 FOR
SET I=$ORDER(OLDLIST(I))
if 'I
QUIT
Begin DoDot:2
+10 SET IDX=$PIECE(OLDLIST(I),U,1)
+11 FOR
if '$DATA(RESULT(IDX))
QUIT
SET IDX=IDX+1
+12 SET IEN=$PIECE(OLDLIST(I),U,2)
+13 DO ADDREM(.RESULT,IDX,IEN)
End DoDot:2
+14 KILL RESULT("B")
End DoDot:1
QUIT
+15 ;
+16 DO REMACCUM(.LST,"PKG","Q",1000)
+17 DO REMACCUM(.LST,"SYS","Q",2000)
+18 DO REMACCUM(.LST,"DIV","Q",3000)
+19 IF +SRV
DO REMACCUM(.LST,"SRV.`"_+$GET(SRV),"Q",4000)
+20 IF +LOC
DO REMACCUM(.LST,"LOC.`"_+$GET(LOC),"Q",5000)
+21 DO REMACCUM(.LST,"CLASS","Q",6000,"",USER)
+22 DO REMACCUM(.LST,"USR.`"_USER,"Q",7000)
+23 SET I=0
+24 FOR
SET I=$ORDER(LST(I))
if 'I
QUIT
Begin DoDot:1
+25 SET IDX=$PIECE(LST(I),U,1)
+26 FOR
if '$DATA(RESULT(IDX))
QUIT
SET IDX=IDX+1
+27 SET CODE=$EXTRACT($PIECE(LST(I),U,2),2)
+28 SET IEN=$EXTRACT($PIECE(LST(I),U,2),3,999)
+29 IF CODE="R"
DO ADDREM(.RESULT,IDX,IEN)
+30 IF CODE="C"
DO ADDCAT(.RESULT,IDX,IEN)
End DoDot:1
+31 KILL RESULT("B")
+32 QUIT
+33 ;
LVREMLST(RESULT,LVL,CLASS) ;Returns cover sheet reminders at a specified level
+1 DO REMACCUM(.RESULT,LVL,"Q","",$GET(CLASS))
+2 QUIT
+3 ;
GETLVRD(RESULT,LVL,CLASS) ;
+1 NEW CAT,CINC,DIEN,IEN,INC,REMLIST,RIEN,REM,TEMP
+2 DO LVREMLST(.REMLIST,LVL,$GET(CLASS))
+3 SET INC=0
FOR
SET INC=$ORDER(REMLIST(INC))
if INC'>0
QUIT
Begin DoDot:1
+4 SET TEMP=$PIECE($GET(REMLIST(INC)),U,2)
IF TEMP=""
QUIT
+5 IF $EXTRACT(TEMP)="R"
QUIT
+6 IF $EXTRACT(TEMP,2)="C"
Begin DoDot:2
+7 SET CAT=$EXTRACT(TEMP,3,$LENGTH(TEMP))
+8 DO CATREM^PXRMAPI0(CAT,.REM)
+9 SET CINC=0
FOR
SET CINC=$ORDER(REM(CINC))
if CINC'>0
QUIT
Begin DoDot:3
+10 SET IEN=$GET(REM(CINC))
if IEN'>0
QUIT
+11 SET DIEN=+$GET(^PXD(811.9,IEN,51))
if DIEN'>0
QUIT
+12 SET RESULT("REMINDER",DIEN)=""
End DoDot:3
End DoDot:2
+13 SET IEN=$EXTRACT(TEMP,3,$LENGTH(TEMP))
+14 SET DIEN=+$GET(^PXD(811.9,IEN,51))
if DIEN'>0
QUIT
+15 SET RESULT("REMINDER",DIEN)=""
End DoDot:1
+16 QUIT
+17 ;
GETDLIST(RESULT,USER,LOC) ;
+1 ;get coversheet reminders list.
+2 NEW IEN,NODE,NUM,REMLIST
+3 DO GETLIST(.REMLIST,USER,$GET(LOC))
+4 SET NUM=0
FOR
SET NUM=$ORDER(REMLIST(NUM))
if NUM'>0
QUIT
Begin DoDot:1
+5 SET IEN=+$GET(REMLIST(NUM))
IF IEN'>0
QUIT
+6 IF +$GET(^PXD(811.9,IEN,51))>0
SET RESULT("REMINDER",+$GET(^PXD(811.9,IEN,51)))=""
End DoDot:1
+7 QUIT
+8 ;
GETTDLST(RESULT) ;
+1 ;get TIU template reminder dialogs list.
+2 NEW IEN,NODE,NUM,REMLIST
+3 SET IEN=0
FOR
SET IEN=$ORDER(^TIU(8927,IEN))
if IEN'>0
QUIT
Begin DoDot:1
+4 SET NODE=$GET(^TIU(8927,IEN,0))
+5 IF $PIECE(NODE,U,15)>0
SET RESULT("TEMPLATE",$PIECE(NODE,U,15))=""
End DoDot:1
+6 QUIT
+7 ;
GETLIST(RESULT,USER,LOC) ;Returns a list of all cover sheet reminders
+1 NEW I
+2 DO REMLIST(.RESULT,USER,$GET(LOC))
+3 SET I=0
+4 FOR
SET I=$ORDER(RESULT(I))
if 'I
QUIT
Begin DoDot:1
+5 SET RESULT(I)=$PIECE(RESULT(I),U,2)
End DoDot:1
+6 QUIT
+7 ;
EVALCOVR(RESULT,PT,LOC) ; Evaluate Cover Sheet Reminders
+1 NEW ORTMP
+2 DO GETLIST(.ORTMP,$GET(LOC))
+3 DO ALIST^ORQQPXRM(.RESULT,PT,.ORTMP)
+4 QUIT
+5 ;
