PXRMASU ;SLC/PKR - Clinical Reminder ASU routines. ;01/29/2010
;;2.0;CLINICAL REMINDERS;**17**;Feb 04, 2005;Build 102
;==========================================================
CLASS(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;Computed finding
;for user class. Use of USRLM covered by DBIA #2324.
S NFOUND=0
Q:NGET=0
N CLASSOK,CLIST,CNAME,EFFDATE,EXPDATE,FEFFDATE,DONE,IND,JND,LIST
N NOCC,OLIST,OVERLAP,SDIR,TCLASS,USER
S TCLASS=TEST
S USER=DUZ
D WHATIS^USRLM(USER,"LIST",1)
;Order the list by Effective Date.
S IND=0
F S IND=$O(LIST(IND)) Q:IND="" D
. S EFFDATE=+$P(LIST(IND),U,4),EXPDATE=$P(LIST(IND),U,5)
. I EXPDATE="" S EXPDATE=$$NOW^PXRMDATE
.;Only keep the entries whose date range, defined by Effective Date
.;and Expiration Date is in the date range defined by BDT and EDT.
. I $$OVERLAP^PXRMINDX(EFFDATE,EXPDATE,BDT,EDT)'="O" Q
.;If TCLASS is not null then check for membership in the specified
.;class or subclass.
. S CLASSOK=$S(TCLASS="":1,TCLASS=$P(LIST(IND),U,3):1,1:$$SUBCLASS^USRLM($P(LIST(IND),U,1),TCLASS))
. I CLASSOK S JND(EFFDATE)=+$G(JND(EFFDATE))+1,OLIST(EFFDATE,JND(EFFDATE))=LIST(IND)
S SDIR=$S(NGET>0:-1,1:1)
S NOCC=$S(NGET>0:NGET,1:-NGET)
S DONE=0,EFFDATE=""
F S EFFDATE=$O(OLIST(EFFDATE),SDIR) Q:(DONE)!(EFFDATE="") D
. S IND=0
. F S IND=$O(OLIST(EFFDATE,IND)) Q:(DONE)!(IND="") D
.. S CNAME=$P(OLIST(EFFDATE,IND),U,3)
.. S EXPDATE=$P(OLIST(EFFDATE,IND),U,5)
.. S NFOUND=NFOUND+1
.. I NFOUND=NOCC S DONE=1
.. S TEST(NFOUND)=1
.. S DATE(NFOUND)=EFFDATE
.. S DATA(NFOUND,"ASU CLASS")=CNAME
.. S DATA(NFOUND,"EFFECTIVE DATE")=EFFDATE
.. S DATA(NFOUND,"EXPIRATION DATE")=EXPDATE
.. S FEFFDATE=$S(EFFDATE=0:"00/00/0000",1:$$FMTE^XLFDT(EFFDATE,"5Z"))
.. I EXPDATE'="" S EXPDATE=$$EDATE^PXRMDATE(EXPDATE)
.. S TEXT(NFOUND)=CNAME_" ("_FEFFDATE_" - "_EXPDATE_")"
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMASU 1882 printed Dec 13, 2024@01:43:02 Page 2
PXRMASU ;SLC/PKR - Clinical Reminder ASU routines. ;01/29/2010
+1 ;;2.0;CLINICAL REMINDERS;**17**;Feb 04, 2005;Build 102
+2 ;==========================================================
CLASS(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;Computed finding
+1 ;for user class. Use of USRLM covered by DBIA #2324.
+2 SET NFOUND=0
+3 if NGET=0
QUIT
+4 NEW CLASSOK,CLIST,CNAME,EFFDATE,EXPDATE,FEFFDATE,DONE,IND,JND,LIST
+5 NEW NOCC,OLIST,OVERLAP,SDIR,TCLASS,USER
+6 SET TCLASS=TEST
+7 SET USER=DUZ
+8 DO WHATIS^USRLM(USER,"LIST",1)
+9 ;Order the list by Effective Date.
+10 SET IND=0
+11 FOR
SET IND=$ORDER(LIST(IND))
if IND=""
QUIT
Begin DoDot:1
+12 SET EFFDATE=+$PIECE(LIST(IND),U,4)
SET EXPDATE=$PIECE(LIST(IND),U,5)
+13 IF EXPDATE=""
SET EXPDATE=$$NOW^PXRMDATE
+14 ;Only keep the entries whose date range, defined by Effective Date
+15 ;and Expiration Date is in the date range defined by BDT and EDT.
+16 IF $$OVERLAP^PXRMINDX(EFFDATE,EXPDATE,BDT,EDT)'="O"
QUIT
+17 ;If TCLASS is not null then check for membership in the specified
+18 ;class or subclass.
+19 SET CLASSOK=$SELECT(TCLASS="":1,TCLASS=$PIECE(LIST(IND),U,3):1,1:$$SUBCLASS^USRLM($PIECE(LIST(IND),U,1),TCLASS))
+20 IF CLASSOK
SET JND(EFFDATE)=+$GET(JND(EFFDATE))+1
SET OLIST(EFFDATE,JND(EFFDATE))=LIST(IND)
End DoDot:1
+21 SET SDIR=$SELECT(NGET>0:-1,1:1)
+22 SET NOCC=$SELECT(NGET>0:NGET,1:-NGET)
+23 SET DONE=0
SET EFFDATE=""
+24 FOR
SET EFFDATE=$ORDER(OLIST(EFFDATE),SDIR)
if (DONE)!(EFFDATE="")
QUIT
Begin DoDot:1
+25 SET IND=0
+26 FOR
SET IND=$ORDER(OLIST(EFFDATE,IND))
if (DONE)!(IND="")
QUIT
Begin DoDot:2
+27 SET CNAME=$PIECE(OLIST(EFFDATE,IND),U,3)
+28 SET EXPDATE=$PIECE(OLIST(EFFDATE,IND),U,5)
+29 SET NFOUND=NFOUND+1
+30 IF NFOUND=NOCC
SET DONE=1
+31 SET TEST(NFOUND)=1
+32 SET DATE(NFOUND)=EFFDATE
+33 SET DATA(NFOUND,"ASU CLASS")=CNAME
+34 SET DATA(NFOUND,"EFFECTIVE DATE")=EFFDATE
+35 SET DATA(NFOUND,"EXPIRATION DATE")=EXPDATE
+36 SET FEFFDATE=$SELECT(EFFDATE=0:"00/00/0000",1:$$FMTE^XLFDT(EFFDATE,"5Z"))
+37 IF EXPDATE'=""
SET EXPDATE=$$EDATE^PXRMDATE(EXPDATE)
+38 SET TEXT(NFOUND)=CNAME_" ("_FEFFDATE_" - "_EXPDATE_")"
End DoDot:2
End DoDot:1
+39 QUIT
+40 ;
