PXRMCVRP ;SLC/PKR - Cover sheet reminder report. ;01/22/2020
;;2.0;CLINICAL REMINDERS;**42**;Feb 04, 2005;Build 245
;==============================
ADDCAT(CATIEN,IDX,IND,LIST,REMLIST) ;Add reminders in a Category to
;the list.
N CATLIST,CATIDX,CATIND,DEC,JND,REMIEN
D CATREM^PXRMAPI0(CATIEN,.CATLIST)
S JND=0
F S JND=+$O(CATLIST(JND)) Q:JND=0 D
. S DEC=.00001*JND
. S CATIND=IND+DEC
. S CATIDX=IDX+DEC
. S REMIEN=CATLIST(JND)
. S LIST(CATIND)=CATIDX_U_REMIEN
. D ADDREM(REMIEN,CATIDX,CATIND,.LIST,.REMLIST)
Q
;
;==============================
ADDLIST(LIST,REMLIST) ;Add a list of reminders in the new parameter
;format to the final list.
I '$D(LIST) Q
N CODE,IEN,IDX,IND,TEMP
S IND=0
F S IND=+$O(LIST(IND)) Q:IND=0 D
. S IDX=$P(LIST(IND),U,1)
. S TEMP=$P(LIST(IND),U,2)
. S CODE=$E(TEMP,2)
. I CODE="R" S IEN=$P(TEMP,"R",2) D ADDREM(IEN,IDX,IND,.LIST,.REMLIST) Q
. I CODE="C" S IEN=$P(TEMP,"C",2) D ADDCAT(IEN,IDX,IND,.LIST,.REMLIST)
Q
;
;==============================
ADDLISTO(LIST,REMLIST) ;Add a list of reminders in the old format to the
;final list.
I '$D(LIST) Q
N IEN,IDX,IND
S IND=0
F S IND=+$O(LIST(IND)) Q:IND=0 D
. S IDX=$P(LIST(IND),U,1)
. S IEN=$P(LIST(IND),U,2)
. D ADDREM(IEN,IDX,IND,.LIST,.REMLIST)
Q
;
;==============================
ADDREM(IEN,IDX,IND,LIST,REMLIST) ;Add a reminder to the reminder list.
;If it is already on the reminder list don't add it again.
I $D(REMLIST("IEN",IEN)) Q
;If it does not exist don't add it.
I '$D(^PXD(811.9,IEN)) S $P(LIST(IND),U,3)="DOES NOT EXIST" Q
;If it is not active don't add it.
I $P(^PXD(811.9,IEN,0),U,6)=1 S $P(LIST(IND),U,3)="INACTIVE" Q
;If it is not a cover sheet reminder don't add it.
N USAGE
S USAGE=$P(^PXD(811.9,IEN,100),U,4)
I (USAGE["L")!(USAGE["O") S $P(LIST(IND),U,3)="NOT A COVER SHEET REMINDER" Q
I (USAGE'["C")&(USAGE'["*") S $P(LIST(IND),U,3)="NOT A COVER SHEET REMINDER" Q
S REMLIST(IDX)=IEN
S REMLIST("IEN",IEN)=""
Q
;
;==============================
CPRSLIST(LIST,LVLLIST,USELECT) ;Build the cover sheet reminder list just like
;CPRS does.
N ERR,LOCATION,LOCP,SERVICE,TLIST,TREMLIST,USER,USERP
S LOCATION=USELECT("CPRS","LOCATION")
S USER=USELECT("CPRS","USER")
S LOCP=$P(LOCATION,U,1),USERP=$P(USER,U,1)
D REMACCUM^PXRMCVRL(.LIST,"PKG","Q",1000)
D REMACCUM^PXRMCVRL(.LIST,"SYS","Q",2000)
D REMACCUM^PXRMCVRL(.LIST,"DIV","Q",3000)
S SERVICE=$$GET1^DIQ(200,USERP,29,"I")
I +SERVICE D
. D REMACCUM^PXRMCVRL(.LIST,"SRV.`"_SERVICE,"Q",4000)
. S USELECT("CPRS","SERVICE")=$$GET1^DIQ(200,USERP,29)
I +LOCP D REMACCUM^PXRMCVRL(.LIST,"LOC.`"_LOCP,"Q",5000)
D REMACCUM^PXRMCVRL(.LIST,"CLASS","Q",6000,"",USERP)
D CPRSCVUC(USERP,.USELECT)
D REMACCUM^PXRMCVRL(.LIST,"USR.`"_USERP,"Q",7000)
D ADDLIST(.LIST,.TREMLIST) K TREMLIST("IEN")
M REMLIST(LVLLIST(LI),"REM")=TREMLIST
M REMLIST(LVLLIST(LI),"LIST")=LIST
Q
;
;==============================
CPRSCVUC(USER,USELECT) ;Return the cover sheet user classes the user is a
;member of.
N CLASS,CLASSLIST,CLASSPARAM,ERR,IND
S CLASSPARAM="ORQQPX COVER SHEET REM CLASSES"
D GETLST^XPAR(.CLASSLIST,"SYS",CLASSPARAM,"Q",.ERR)
S IND=0
F S IND=$O(CLASSLIST(IND)) Q:'IND D
. S CLASS=$P(CLASSLIST(IND),U,1)
. I $$ISA^USRLM(USER,CLASS,.ERR) D
.. S USELECT("CPRS","USER CLASS",CLASS)=$$CLNAME^USRLM(CLASS,1)
Q
;
;==============================
NEWRPP() ;Ask the user if they want to use the new reminder parameters.
N DIR,DUOUT,DTOUT
S DIR(0)="S^1:YES;2:NO"
S DIR("B")="YES"
W !,"Do you want to use the new reminder parameters?"
D ^DIR
I $D(DUOUT)!$D(DTOUT) Q 0
Q $S(Y=1:1,Y=2:0)
;
;==============================
NEWPARAM(LVLLIST,SELLIST,USELECT,REMLIST) ;Produce the reminder list using
;the new parameters.
N ERR,IND,LI,LIST,TLIST,TREMLIST
S LI=0
F S LI=$O(SELLIST(LI)) Q:LI="" D
. I LVLLIST(LI)="PACKAGE" D Q
.. D REMACCUM^PXRMCVRL(.LIST,"PKG","Q",1000)
.. K TLIST,TREMLIST
.. M TLIST=LIST D ADDLIST(.TLIST,.TREMLIST) K TREMLIST("IEN")
.. M REMLIST(LVLLIST(LI),"REM")=TREMLIST
.. M REMLIST(LVLLIST(LI),"LIST")=TLIST
. I LVLLIST(LI)="SYSTEM" D Q
.. D REMACCUM^PXRMCVRL(.LIST,"SYS","Q",2000)
.. K TLIST,TREMLIST
.. M TLIST=LIST D ADDLIST(.TLIST,.TREMLIST) K TREMLIST("IEN")
.. M REMLIST(LVLLIST(LI),"REM")=TREMLIST
.. M REMLIST(LVLLIST(LI),"LIST")=TLIST
. I LVLLIST(LI)="DIVISION" D Q
.. D REMACCUM^PXRMCVRL(.LIST,"DIV.`"_$P(USELECT(LI),U,1),"Q",3000)
.. K TLIST,TREMLIST
.. M TLIST=LIST D ADDLIST(.TLIST,.TREMLIST) K TREMLIST("IEN")
.. M REMLIST(LVLLIST(LI),"REM")=TREMLIST
.. M REMLIST(LVLLIST(LI),"LIST")=TLIST
. I LVLLIST(LI)="SERVICE" D Q
.. D REMACCUM^PXRMCVRL(.LIST,"SRV.`"_$P(USELECT(LI),U,1),"Q",4000)
.. K TLIST,TREMLIST
.. M TLIST=LIST D ADDLIST(.TLIST,.TREMLIST) K TREMLIST("IEN")
.. M REMLIST(LVLLIST(LI),"REM")=TREMLIST
.. M REMLIST(LVLLIST(LI),"LIST")=TLIST
. I LVLLIST(LI)="LOCATION" D Q
.. D REMACCUM^PXRMCVRL(.LIST,"LOC.`"_$P(USELECT(LI),U,1),"Q",5000)
.. K TLIST,TREMLIST
.. M TLIST=LIST D ADDLIST(.TLIST,.TREMLIST) K TREMLIST("IEN")
.. M REMLIST(LVLLIST(LI),"REM")=TREMLIST
.. M REMLIST(LVLLIST(LI),"LIST")=TLIST
. I LVLLIST(LI)="USER CLASS" D Q
.. D REMACCUM^PXRMCVRL(.LIST,"CLASS","Q",6000,$P(USELECT(LI),U,1))
.. K TLIST,TREMLIST
.. M TLIST=LIST D ADDLIST(.TLIST,.TREMLIST) K TREMLIST("IEN")
.. M REMLIST(LVLLIST(LI),"REM")=TREMLIST
.. M REMLIST(LVLLIST(LI),"LIST")=TLIST
. I LVLLIST(LI)="USER" D Q
.. D REMACCUM^PXRMCVRL(.LIST,"USR.`"_$P(USELECT(LI),U,1),"Q",7000)
.. K TLIST,TREMLIST
.. M TLIST=LIST D ADDLIST(.TLIST,.TREMLIST) K TREMLIST("IEN")
.. M REMLIST(LVLLIST(LI),"REM")=TREMLIST
.. M REMLIST(LVLLIST(LI),"LIST")=TLIST
. I LVLLIST(LI)="CPRS" D CPRSLIST(.LIST,.LVLLIST,.USELECT)
Q
;
;==============================
NEWREMP(USER) ;
N ERR,GBL,RESULT,SERVICE
S SERVICE=$$GET1^DIQ(200,USER,29,"I")
D GETLST^XPAR(.RESULT,"USR.`"_USER_"^SRV.`"_SERVICE_"^DIV^SYS^PKG","ORQQPX NEW REMINDER PARAMS","I",.ERR)
Q RESULT
;
;==============================
OLDPARAM(LVLLIST,SELLIST,USELECT,REMLIST) ;Produce the reminder list using
;the old parameters. Under the old parameters the list is built
;processing the entity string from left to right, it stops with
;the first item in the entity list that is populated. Then entity
;list is built in the order: USER, LOCATION, SERVICE, DIVISION,
;SYSTEM, PACKAGE.
N DIVISION,ENTITY,ERR,IND,LI,LIST,LOCATION,SERVICE,TENTITY,USER
S LI=0
F S LI=$O(SELLIST(LI)) Q:LI="" D
. I LVLLIST(LI)="PACKAGE" D Q
.. S $P(ENTITY,U,6)="PKG"
.. K TENTITY
.. S $P(TENTITY,U,6)="PKG"
.. D OLDPARAML(LVLLIST(LI),TENTITY,.REMLIST)
. I LVLLIST(LI)="SYSTEM" D Q
.. S $P(ENTITY,U,5)="SYS"
.. K TENTITY
.. S $P(TENTITY,U,5)="SYS"
.. D OLDPARAML(LVLLIST(LI),TENTITY,.REMLIST)
. I LVLLIST(LI)="DIVISION" D Q
.. S DIVISION="DIV.`"_$P(USELECT(LI),U,1)
.. S $P(ENTITY,U,4)=DIVISION
.. K TENTITY
.. S $P(TENTITY,U,4)=DIVISION
.. D OLDPARAML(LVLLIST(LI),TENTITY,.REMLIST)
. I LVLLIST(LI)="SERVICE" D Q
.. S SERVICE="SRV.`"_$P(USELECT(LI),U,1)
.. S $P(ENTITY,U,3)=SERVICE
.. K TENTITY
.. S $P(TENTITY,U,3)=SERVICE
.. D OLDPARAML(LVLLIST(LI),TENTITY,.REMLIST)
. I LVLLIST(LI)="LOCATION" D Q
.. S LOCATION="LOC.`"_$P(USELECT(LI),U,1)
.. S $P(ENTITY,U,2)=LOCATION
.. K TENTITY
.. S $P(TENTITY,U,2)=LOCATION
.. D OLDPARAML(LVLLIST(LI),TENTITY,.REMLIST)
. I LVLLIST(LI)="USER" D Q
.. S USER="USR.`"_$P(USELECT(LI),U,1)
.. S $P(ENTITY,U,1)=USER
.. K TENTITY
.. S $P(TENTITY,U,1)=USER
.. D OLDPARAML(LVLLIST(LI),TENTITY,.REMLIST)
. I LVLLIST(LI)="CPRS" D
.. S USER=USELECT("CPRS","USER")
.. S LOCATION=USELECT("CPRS","LOCATION")
.. S SERVICE=$$GET1^DIQ(200,$P(USER,U,1),29,"I")
.. S ENTITY="USR.`"_$P(USER,U,1)_U_"LOC.`"_$P(LOCATION,U,1)_U_"SRV.`"_SERVICE_U_"DIV^SYS^PKG"
.. D OLDPARAML(LVLLIST(LI),ENTITY,.REMLIST)
D GETLST^XPAR(.LIST,ENTITY,"ORQQPX SEARCH ITEMS","Q",.ERR)
D ADDLISTO(.LIST,.REMLIST) K REMLIST("IEN")
Q
;
;==============================
OLDPARAML(LEVEL,ENTITY,REMLIST) ;Create the old parameter list at a
;specific level.
N LIST,TREMLIST
D GETLST^XPAR(.LIST,ENTITY,"ORQQPX SEARCH ITEMS","Q",.ERR)
D ADDLISTO(.LIST,.TREMLIST) K TREMLIST("IEN")
M REMLIST(LEVEL,"REM")=TREMLIST
M REMLIST(LEVEL,"LIST")=LIST
Q
;
;==============================
REPD ;Main report driver.
N DONE,LI,LVLLIST,NEWRP,NUM,REMLIST,SELLIST,USELDONE,USELECT
S DONE=0
W !,"Clinical Reminders Cover Sheet Reminder List Report"
S NEWRP=$$NEWRPP
F Q:DONE D
.;Get a list of levels for the report.
. D SELLIST(NEWRP,.LVLLIST,.SELLIST)
. I '$D(SELLIST) S DONE=1 Q
. K REMLIST,USELECT
. S (LI,USELDONE)=0
. F S LI=$O(SELLIST(LI)) Q:(LI="")!(USELDONE) D
.. I LVLLIST(LI)="DIVISION" D Q
... S USELECT(LI)=$$SELECT(4,"Select the division: ")
... I USELECT(LI)=-1 S USELDONE=1
.. I LVLLIST(LI)="SERVICE" D Q
... S USELECT(LI)=$$SELECT(49,"Select the service: ")
... I USELECT(LI)=-1 S USELDONE=1
.. I LVLLIST(LI)="LOCATION" D Q
... S USELECT(LI)=$$SELECT(44,"Select the location: ")
... I USELECT(LI)=-1 S USELDONE=1
.. I LVLLIST(LI)="USER CLASS" D Q
... S USELECT(LI)=$$SELECT(8930,"Select the user class: ")
... I USELECT(LI)=-1 S USELDONE=1
.. I LVLLIST(LI)="USER" D Q
... S USELECT(LI)=$$SELECT(200,"Select the user: ")
... I USELECT(LI)=-1 S USELDONE=1
.. I LVLLIST(LI)="CPRS" D Q
... S USELECT("CPRS","USER")=$$SELECT(200,"Select the user: ")
... I USELECT("CPRS","USER")=-1 S USELDONE=1 Q
... S USELECT("CPRS","LOCATION")=$$SELECT(44,"Select the location: ")
... I USELECT("CPRS","LOCATION")=-1 S USELDONE=1
. I USELDONE=1 Q
. I NEWRP D NEWPARAM(.LVLLIST,.SELLIST,.USELECT,.REMLIST)
. I 'NEWRP D OLDPARAM(.LVLLIST,.SELLIST,.USELECT,.REMLIST)
. K REMLIST("IEN")
.;Produce the report.
. D REPORT(NEWRP,.LVLLIST,.SELLIST,.USELECT,.REMLIST)
Q
;
;==============================
REPORT(NEWRP,LVLLIST,SELLIST,USELECT,REMLIST) ;Generate the report.
N BOP,FIRST,IEN,IND,NDEF,NL,LEVELS,LI,OUTPUT,SELECT,TEMP
S NL=0
S NL=NL+1,OUTPUT(NL)="Report Criteria"
S NL=NL+1,OUTPUT(NL)="Use new cover sheet parameters: "_$S(NEWRP=1:"YES",1:"NO")
S NL=NL+1,OUTPUT(NL)="Selected levels:"
S LI=0
F S LI=$O(SELLIST(LI)) Q:LI="" D
. S NL=NL+1,OUTPUT(NL)=" "_LVLLIST(LI)
. S SELECT=$G(USELECT(LI))
. I SELECT=-1 S NL=NL+1,OUTPUT(NL)=" Value - No selection"
. I $P(SELECT,U,2)'="" S NL=NL+1,OUTPUT(NL)=" Value - "_$P(SELECT,U,2)
. I LVLLIST(LI)="CPRS" D
.. S NL=NL+1,OUTPUT(NL)=" User - "_$P(USELECT("CPRS","USER"),U,2)
.. S NL=NL+1,OUTPUT(NL)=" Location - "_$P(USELECT("CPRS","LOCATION"),U,2)
.. I 'NEWRP Q
.. S NL=NL+1,OUTPUT(NL)=" Service - "_USELECT("CPRS","SERVICE")
.. S IND=0
.. F S IND=$O(USELECT("CPRS","USER CLASS",IND)) Q:IND="" D
... S NL=NL+1,OUTPUT(NL)=" User Class - "_USELECT("CPRS","USER CLASS",IND)
S NL=NL+1,OUTPUT(NL)=""
S FIRST=$O(SELLIST(0))
S LEVELS="",LI=0
F S LI=$O(SELLIST(LI)) Q:LI="" D
. S NL=NL+1,OUTPUT(NL)=""
. I NEWRP D
.. I LI>FIRST S LEVELS=LEVELS_","
.. S LEVELS=LEVELS_" "_LVLLIST(LI)
.. S NL=NL+1,OUTPUT(NL)="Reminder list at"_LEVELS
.. S OUTPUT(NL)=OUTPUT(NL)_$S(LI=FIRST:" level",1:" levels")
. I 'NEWRP D
.. S LEVELS=LVLLIST(LI)
.. S NL=NL+1,OUTPUT(NL)="Reminder list at the "_LEVELS_" level"
. S IND=0
. F S IND=+$O(REMLIST(LVLLIST(LI),"LIST",IND)) Q:IND=0 D
.. S NL=NL+1,OUTPUT(NL)="LIST("_IND_")="_REMLIST(LVLLIST(LI),"LIST",IND)
. S IND="",NDEF=0
. S NL=NL+1,OUTPUT(NL)=""
. S NL=NL+1,OUTPUT(NL)="Reminders in Display Order"
. F S IND=$O(REMLIST(LVLLIST(LI),"REM",IND)) Q:IND="" D
.. S NDEF=NDEF+1
.. S IEN=REMLIST(LVLLIST(LI),"REM",IND)
.. S TEMP=^PXD(811.9,IEN,0)
.. I NDEF>1 S NL=NL+1,OUTPUT(NL)=""
.. S NL=NL+1,OUTPUT(NL)="Name - "_$P(TEMP,U,1)_" (IEN="_IEN_")"
.. S NL=NL+1,OUTPUT(NL)="Print Name - "_$P(TEMP,U,3)
. S NL=NL+1,OUTPUT(NL)=""
. S NL=NL+1,OUTPUT(NL)="There are "_NDEF_" reminders on the list."
I 'NEWRP,'$D(REMLIST("CPRS")) D
. S NL=NL+1,OUTPUT(NL)=""
. S NL=NL+1,OUTPUT(NL)="Final Reminder List"
. S IND=0,NDEF=0
.F S IND=+$O(REMLIST(IND)) Q:IND=0 D
.. S NDEF=NDEF+1
.. S IEN=REMLIST(IND)
.. S TEMP=^PXD(811.9,IEN,0)
.. I NDEF>1 S NL=NL+1,OUTPUT(NL)=""
.. S NL=NL+1,OUTPUT(NL)="Name - "_$P(TEMP,U,1)
.. S NL=NL+1,OUTPUT(NL)="Print Name - "_$P(TEMP,U,3)
. S NL=NL+1,OUTPUT(NL)=""
. S NL=NL+1,OUTPUT(NL)="There are "_NDEF_" reminders on the list."
. S NL=NL+1,OUTPUT(NL)=""
S BOP=$$BORP^PXRMUTIL("B")
I BOP="B" D
. S X="IORESET"
. D ENDR^%ZISS
. D BROWSE^DDBR("OUTPUT","NR","CPRS Cover Sheet Reminder List")
. W IORESET
. D KILL^%ZISS
I BOP="P" D GPRINT^PXRMUTIL("OUTPUT")
Q
;
;==============================
SELECT(FILENUM,PROMPT) ;Let the user make a selection.
N DIC,DONE,X,Y
S DIC=FILENUM,DIC(0)="AEO"
S DIC("A")=PROMPT
S DONE=0
F Q:DONE D
. D ^DIC
. I X'="" S DONE=1
Q Y
;
;==============================
SELLIST(NEWRP,LVLLIST,OLIST) ;Build a list of selections and let the user
;select from the list.
N CPRSLVL,DIR,DIROUT,DIRUT,DTOUT,DUOUT,IND,NLVL,SELLIST,X,Y
K OLIST
S NLVL=0
S NLVL=NLVL+1,SELLIST(NLVL)=" "_$J(NLVL,4)_" - PACKAGE",LVLLIST(NLVL)="PACKAGE"
S NLVL=NLVL+1,SELLIST(NLVL)=" "_$J(NLVL,4)_" - SYSTEM",LVLLIST(NLVL)="SYSTEM"
S NLVL=NLVL+1,SELLIST(NLVL)=" "_$J(NLVL,4)_" - DIVISION",LVLLIST(NLVL)="DIVISION"
S NLVL=NLVL+1,SELLIST(NLVL)=" "_$J(NLVL,4)_" - SERVICE",LVLLIST(NLVL)="SERVICE"
S NLVL=NLVL+1,SELLIST(NLVL)=" "_$J(NLVL,4)_" - LOCATION",LVLLIST(NLVL)="LOCATION"
I NEWRP S NLVL=NLVL+1,SELLIST(NLVL)=" "_$J(NLVL,4)_" - USER CLASS",LVLLIST(NLVL)="USER CLASS"
S NLVL=NLVL+1,SELLIST(NLVL)=" "_$J(NLVL,4)_" - USER",LVLLIST(NLVL)="USER"
S NLVL=NLVL+1,SELLIST(NLVL)=" "_$J(NLVL,4)_" - CPRS",LVLLIST(NLVL)="CPRS"
S CPRSLVL=NLVL
M DIR("A")=SELLIST
S DIR("A")="Enter your list for the report"
S DIR(0)="LO^1:"_NLVL
W !!,"Select from the following levels:"
D ^DIR
I $D(DIROUT)!$D(DIRUT) K OLIST Q
I $D(DUOUT)!$D(DTOUT) K OLIST Q
;If the list contains CPRS only return CPRS.
I Y[CPRSLVL S Y=CPRSLVL_","
;Make sure the list is ordered.
F IND=1:1:$L(Y,",")-1 S OLIST($P(Y,",",IND))=""
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMCVRP 14346 printed Apr 09, 2024@20:49:24 Page 2
PXRMCVRP ;SLC/PKR - Cover sheet reminder report. ;01/22/2020
+1 ;;2.0;CLINICAL REMINDERS;**42**;Feb 04, 2005;Build 245
+2 ;==============================
ADDCAT(CATIEN,IDX,IND,LIST,REMLIST) ;Add reminders in a Category to
+1 ;the list.
+2 NEW CATLIST,CATIDX,CATIND,DEC,JND,REMIEN
+3 DO CATREM^PXRMAPI0(CATIEN,.CATLIST)
+4 SET JND=0
+5 FOR
SET JND=+$ORDER(CATLIST(JND))
if JND=0
QUIT
Begin DoDot:1
+6 SET DEC=.00001*JND
+7 SET CATIND=IND+DEC
+8 SET CATIDX=IDX+DEC
+9 SET REMIEN=CATLIST(JND)
+10 SET LIST(CATIND)=CATIDX_U_REMIEN
+11 DO ADDREM(REMIEN,CATIDX,CATIND,.LIST,.REMLIST)
End DoDot:1
+12 QUIT
+13 ;
+14 ;==============================
ADDLIST(LIST,REMLIST) ;Add a list of reminders in the new parameter
+1 ;format to the final list.
+2 IF '$DATA(LIST)
QUIT
+3 NEW CODE,IEN,IDX,IND,TEMP
+4 SET IND=0
+5 FOR
SET IND=+$ORDER(LIST(IND))
if IND=0
QUIT
Begin DoDot:1
+6 SET IDX=$PIECE(LIST(IND),U,1)
+7 SET TEMP=$PIECE(LIST(IND),U,2)
+8 SET CODE=$EXTRACT(TEMP,2)
+9 IF CODE="R"
SET IEN=$PIECE(TEMP,"R",2)
DO ADDREM(IEN,IDX,IND,.LIST,.REMLIST)
QUIT
+10 IF CODE="C"
SET IEN=$PIECE(TEMP,"C",2)
DO ADDCAT(IEN,IDX,IND,.LIST,.REMLIST)
End DoDot:1
+11 QUIT
+12 ;
+13 ;==============================
ADDLISTO(LIST,REMLIST) ;Add a list of reminders in the old format to the
+1 ;final list.
+2 IF '$DATA(LIST)
QUIT
+3 NEW IEN,IDX,IND
+4 SET IND=0
+5 FOR
SET IND=+$ORDER(LIST(IND))
if IND=0
QUIT
Begin DoDot:1
+6 SET IDX=$PIECE(LIST(IND),U,1)
+7 SET IEN=$PIECE(LIST(IND),U,2)
+8 DO ADDREM(IEN,IDX,IND,.LIST,.REMLIST)
End DoDot:1
+9 QUIT
+10 ;
+11 ;==============================
ADDREM(IEN,IDX,IND,LIST,REMLIST) ;Add a reminder to the reminder list.
+1 ;If it is already on the reminder list don't add it again.
+2 IF $DATA(REMLIST("IEN",IEN))
QUIT
+3 ;If it does not exist don't add it.
+4 IF '$DATA(^PXD(811.9,IEN))
SET $PIECE(LIST(IND),U,3)="DOES NOT EXIST"
QUIT
+5 ;If it is not active don't add it.
+6 IF $PIECE(^PXD(811.9,IEN,0),U,6)=1
SET $PIECE(LIST(IND),U,3)="INACTIVE"
QUIT
+7 ;If it is not a cover sheet reminder don't add it.
+8 NEW USAGE
+9 SET USAGE=$PIECE(^PXD(811.9,IEN,100),U,4)
+10 IF (USAGE["L")!(USAGE["O")
SET $PIECE(LIST(IND),U,3)="NOT A COVER SHEET REMINDER"
QUIT
+11 IF (USAGE'["C")&(USAGE'["*")
SET $PIECE(LIST(IND),U,3)="NOT A COVER SHEET REMINDER"
QUIT
+12 SET REMLIST(IDX)=IEN
+13 SET REMLIST("IEN",IEN)=""
+14 QUIT
+15 ;
+16 ;==============================
CPRSLIST(LIST,LVLLIST,USELECT) ;Build the cover sheet reminder list just like
+1 ;CPRS does.
+2 NEW ERR,LOCATION,LOCP,SERVICE,TLIST,TREMLIST,USER,USERP
+3 SET LOCATION=USELECT("CPRS","LOCATION")
+4 SET USER=USELECT("CPRS","USER")
+5 SET LOCP=$PIECE(LOCATION,U,1)
SET USERP=$PIECE(USER,U,1)
+6 DO REMACCUM^PXRMCVRL(.LIST,"PKG","Q",1000)
+7 DO REMACCUM^PXRMCVRL(.LIST,"SYS","Q",2000)
+8 DO REMACCUM^PXRMCVRL(.LIST,"DIV","Q",3000)
+9 SET SERVICE=$$GET1^DIQ(200,USERP,29,"I")
+10 IF +SERVICE
Begin DoDot:1
+11 DO REMACCUM^PXRMCVRL(.LIST,"SRV.`"_SERVICE,"Q",4000)
+12 SET USELECT("CPRS","SERVICE")=$$GET1^DIQ(200,USERP,29)
End DoDot:1
+13 IF +LOCP
DO REMACCUM^PXRMCVRL(.LIST,"LOC.`"_LOCP,"Q",5000)
+14 DO REMACCUM^PXRMCVRL(.LIST,"CLASS","Q",6000,"",USERP)
+15 DO CPRSCVUC(USERP,.USELECT)
+16 DO REMACCUM^PXRMCVRL(.LIST,"USR.`"_USERP,"Q",7000)
+17 DO ADDLIST(.LIST,.TREMLIST)
KILL TREMLIST("IEN")
+18 MERGE REMLIST(LVLLIST(LI),"REM")=TREMLIST
+19 MERGE REMLIST(LVLLIST(LI),"LIST")=LIST
+20 QUIT
+21 ;
+22 ;==============================
CPRSCVUC(USER,USELECT) ;Return the cover sheet user classes the user is a
+1 ;member of.
+2 NEW CLASS,CLASSLIST,CLASSPARAM,ERR,IND
+3 SET CLASSPARAM="ORQQPX COVER SHEET REM CLASSES"
+4 DO GETLST^XPAR(.CLASSLIST,"SYS",CLASSPARAM,"Q",.ERR)
+5 SET IND=0
+6 FOR
SET IND=$ORDER(CLASSLIST(IND))
if 'IND
QUIT
Begin DoDot:1
+7 SET CLASS=$PIECE(CLASSLIST(IND),U,1)
+8 IF $$ISA^USRLM(USER,CLASS,.ERR)
Begin DoDot:2
+9 SET USELECT("CPRS","USER CLASS",CLASS)=$$CLNAME^USRLM(CLASS,1)
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
+12 ;==============================
NEWRPP() ;Ask the user if they want to use the new reminder parameters.
+1 NEW DIR,DUOUT,DTOUT
+2 SET DIR(0)="S^1:YES;2:NO"
+3 SET DIR("B")="YES"
+4 WRITE !,"Do you want to use the new reminder parameters?"
+5 DO ^DIR
+6 IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT 0
+7 QUIT $SELECT(Y=1:1,Y=2:0)
+8 ;
+9 ;==============================
NEWPARAM(LVLLIST,SELLIST,USELECT,REMLIST) ;Produce the reminder list using
+1 ;the new parameters.
+2 NEW ERR,IND,LI,LIST,TLIST,TREMLIST
+3 SET LI=0
+4 FOR
SET LI=$ORDER(SELLIST(LI))
if LI=""
QUIT
Begin DoDot:1
+5 IF LVLLIST(LI)="PACKAGE"
Begin DoDot:2
+6 DO REMACCUM^PXRMCVRL(.LIST,"PKG","Q",1000)
+7 KILL TLIST,TREMLIST
+8 MERGE TLIST=LIST
DO ADDLIST(.TLIST,.TREMLIST)
KILL TREMLIST("IEN")
+9 MERGE REMLIST(LVLLIST(LI),"REM")=TREMLIST
+10 MERGE REMLIST(LVLLIST(LI),"LIST")=TLIST
End DoDot:2
QUIT
+11 IF LVLLIST(LI)="SYSTEM"
Begin DoDot:2
+12 DO REMACCUM^PXRMCVRL(.LIST,"SYS","Q",2000)
+13 KILL TLIST,TREMLIST
+14 MERGE TLIST=LIST
DO ADDLIST(.TLIST,.TREMLIST)
KILL TREMLIST("IEN")
+15 MERGE REMLIST(LVLLIST(LI),"REM")=TREMLIST
+16 MERGE REMLIST(LVLLIST(LI),"LIST")=TLIST
End DoDot:2
QUIT
+17 IF LVLLIST(LI)="DIVISION"
Begin DoDot:2
+18 DO REMACCUM^PXRMCVRL(.LIST,"DIV.`"_$PIECE(USELECT(LI),U,1),"Q",3000)
+19 KILL TLIST,TREMLIST
+20 MERGE TLIST=LIST
DO ADDLIST(.TLIST,.TREMLIST)
KILL TREMLIST("IEN")
+21 MERGE REMLIST(LVLLIST(LI),"REM")=TREMLIST
+22 MERGE REMLIST(LVLLIST(LI),"LIST")=TLIST
End DoDot:2
QUIT
+23 IF LVLLIST(LI)="SERVICE"
Begin DoDot:2
+24 DO REMACCUM^PXRMCVRL(.LIST,"SRV.`"_$PIECE(USELECT(LI),U,1),"Q",4000)
+25 KILL TLIST,TREMLIST
+26 MERGE TLIST=LIST
DO ADDLIST(.TLIST,.TREMLIST)
KILL TREMLIST("IEN")
+27 MERGE REMLIST(LVLLIST(LI),"REM")=TREMLIST
+28 MERGE REMLIST(LVLLIST(LI),"LIST")=TLIST
End DoDot:2
QUIT
+29 IF LVLLIST(LI)="LOCATION"
Begin DoDot:2
+30 DO REMACCUM^PXRMCVRL(.LIST,"LOC.`"_$PIECE(USELECT(LI),U,1),"Q",5000)
+31 KILL TLIST,TREMLIST
+32 MERGE TLIST=LIST
DO ADDLIST(.TLIST,.TREMLIST)
KILL TREMLIST("IEN")
+33 MERGE REMLIST(LVLLIST(LI),"REM")=TREMLIST
+34 MERGE REMLIST(LVLLIST(LI),"LIST")=TLIST
End DoDot:2
QUIT
+35 IF LVLLIST(LI)="USER CLASS"
Begin DoDot:2
+36 DO REMACCUM^PXRMCVRL(.LIST,"CLASS","Q",6000,$PIECE(USELECT(LI),U,1))
+37 KILL TLIST,TREMLIST
+38 MERGE TLIST=LIST
DO ADDLIST(.TLIST,.TREMLIST)
KILL TREMLIST("IEN")
+39 MERGE REMLIST(LVLLIST(LI),"REM")=TREMLIST
+40 MERGE REMLIST(LVLLIST(LI),"LIST")=TLIST
End DoDot:2
QUIT
+41 IF LVLLIST(LI)="USER"
Begin DoDot:2
+42 DO REMACCUM^PXRMCVRL(.LIST,"USR.`"_$PIECE(USELECT(LI),U,1),"Q",7000)
+43 KILL TLIST,TREMLIST
+44 MERGE TLIST=LIST
DO ADDLIST(.TLIST,.TREMLIST)
KILL TREMLIST("IEN")
+45 MERGE REMLIST(LVLLIST(LI),"REM")=TREMLIST
+46 MERGE REMLIST(LVLLIST(LI),"LIST")=TLIST
End DoDot:2
QUIT
+47 IF LVLLIST(LI)="CPRS"
DO CPRSLIST(.LIST,.LVLLIST,.USELECT)
End DoDot:1
+48 QUIT
+49 ;
+50 ;==============================
NEWREMP(USER) ;
+1 NEW ERR,GBL,RESULT,SERVICE
+2 SET SERVICE=$$GET1^DIQ(200,USER,29,"I")
+3 DO GETLST^XPAR(.RESULT,"USR.`"_USER_"^SRV.`"_SERVICE_"^DIV^SYS^PKG","ORQQPX NEW REMINDER PARAMS","I",.ERR)
+4 QUIT RESULT
+5 ;
+6 ;==============================
OLDPARAM(LVLLIST,SELLIST,USELECT,REMLIST) ;Produce the reminder list using
+1 ;the old parameters. Under the old parameters the list is built
+2 ;processing the entity string from left to right, it stops with
+3 ;the first item in the entity list that is populated. Then entity
+4 ;list is built in the order: USER, LOCATION, SERVICE, DIVISION,
+5 ;SYSTEM, PACKAGE.
+6 NEW DIVISION,ENTITY,ERR,IND,LI,LIST,LOCATION,SERVICE,TENTITY,USER
+7 SET LI=0
+8 FOR
SET LI=$ORDER(SELLIST(LI))
if LI=""
QUIT
Begin DoDot:1
+9 IF LVLLIST(LI)="PACKAGE"
Begin DoDot:2
+10 SET $PIECE(ENTITY,U,6)="PKG"
+11 KILL TENTITY
+12 SET $PIECE(TENTITY,U,6)="PKG"
+13 DO OLDPARAML(LVLLIST(LI),TENTITY,.REMLIST)
End DoDot:2
QUIT
+14 IF LVLLIST(LI)="SYSTEM"
Begin DoDot:2
+15 SET $PIECE(ENTITY,U,5)="SYS"
+16 KILL TENTITY
+17 SET $PIECE(TENTITY,U,5)="SYS"
+18 DO OLDPARAML(LVLLIST(LI),TENTITY,.REMLIST)
End DoDot:2
QUIT
+19 IF LVLLIST(LI)="DIVISION"
Begin DoDot:2
+20 SET DIVISION="DIV.`"_$PIECE(USELECT(LI),U,1)
+21 SET $PIECE(ENTITY,U,4)=DIVISION
+22 KILL TENTITY
+23 SET $PIECE(TENTITY,U,4)=DIVISION
+24 DO OLDPARAML(LVLLIST(LI),TENTITY,.REMLIST)
End DoDot:2
QUIT
+25 IF LVLLIST(LI)="SERVICE"
Begin DoDot:2
+26 SET SERVICE="SRV.`"_$PIECE(USELECT(LI),U,1)
+27 SET $PIECE(ENTITY,U,3)=SERVICE
+28 KILL TENTITY
+29 SET $PIECE(TENTITY,U,3)=SERVICE
+30 DO OLDPARAML(LVLLIST(LI),TENTITY,.REMLIST)
End DoDot:2
QUIT
+31 IF LVLLIST(LI)="LOCATION"
Begin DoDot:2
+32 SET LOCATION="LOC.`"_$PIECE(USELECT(LI),U,1)
+33 SET $PIECE(ENTITY,U,2)=LOCATION
+34 KILL TENTITY
+35 SET $PIECE(TENTITY,U,2)=LOCATION
+36 DO OLDPARAML(LVLLIST(LI),TENTITY,.REMLIST)
End DoDot:2
QUIT
+37 IF LVLLIST(LI)="USER"
Begin DoDot:2
+38 SET USER="USR.`"_$PIECE(USELECT(LI),U,1)
+39 SET $PIECE(ENTITY,U,1)=USER
+40 KILL TENTITY
+41 SET $PIECE(TENTITY,U,1)=USER
+42 DO OLDPARAML(LVLLIST(LI),TENTITY,.REMLIST)
End DoDot:2
QUIT
+43 IF LVLLIST(LI)="CPRS"
Begin DoDot:2
+44 SET USER=USELECT("CPRS","USER")
+45 SET LOCATION=USELECT("CPRS","LOCATION")
+46 SET SERVICE=$$GET1^DIQ(200,$PIECE(USER,U,1),29,"I")
+47 SET ENTITY="USR.`"_$PIECE(USER,U,1)_U_"LOC.`"_$PIECE(LOCATION,U,1)_U_"SRV.`"_SERVICE_U_"DIV^SYS^PKG"
+48 DO OLDPARAML(LVLLIST(LI),ENTITY,.REMLIST)
End DoDot:2
End DoDot:1
+49 DO GETLST^XPAR(.LIST,ENTITY,"ORQQPX SEARCH ITEMS","Q",.ERR)
+50 DO ADDLISTO(.LIST,.REMLIST)
KILL REMLIST("IEN")
+51 QUIT
+52 ;
+53 ;==============================
OLDPARAML(LEVEL,ENTITY,REMLIST) ;Create the old parameter list at a
+1 ;specific level.
+2 NEW LIST,TREMLIST
+3 DO GETLST^XPAR(.LIST,ENTITY,"ORQQPX SEARCH ITEMS","Q",.ERR)
+4 DO ADDLISTO(.LIST,.TREMLIST)
KILL TREMLIST("IEN")
+5 MERGE REMLIST(LEVEL,"REM")=TREMLIST
+6 MERGE REMLIST(LEVEL,"LIST")=LIST
+7 QUIT
+8 ;
+9 ;==============================
REPD ;Main report driver.
+1 NEW DONE,LI,LVLLIST,NEWRP,NUM,REMLIST,SELLIST,USELDONE,USELECT
+2 SET DONE=0
+3 WRITE !,"Clinical Reminders Cover Sheet Reminder List Report"
+4 SET NEWRP=$$NEWRPP
+5 FOR
if DONE
QUIT
Begin DoDot:1
+6 ;Get a list of levels for the report.
+7 DO SELLIST(NEWRP,.LVLLIST,.SELLIST)
+8 IF '$DATA(SELLIST)
SET DONE=1
QUIT
+9 KILL REMLIST,USELECT
+10 SET (LI,USELDONE)=0
+11 FOR
SET LI=$ORDER(SELLIST(LI))
if (LI="")!(USELDONE)
QUIT
Begin DoDot:2
+12 IF LVLLIST(LI)="DIVISION"
Begin DoDot:3
+13 SET USELECT(LI)=$$SELECT(4,"Select the division: ")
+14 IF USELECT(LI)=-1
SET USELDONE=1
End DoDot:3
QUIT
+15 IF LVLLIST(LI)="SERVICE"
Begin DoDot:3
+16 SET USELECT(LI)=$$SELECT(49,"Select the service: ")
+17 IF USELECT(LI)=-1
SET USELDONE=1
End DoDot:3
QUIT
+18 IF LVLLIST(LI)="LOCATION"
Begin DoDot:3
+19 SET USELECT(LI)=$$SELECT(44,"Select the location: ")
+20 IF USELECT(LI)=-1
SET USELDONE=1
End DoDot:3
QUIT
+21 IF LVLLIST(LI)="USER CLASS"
Begin DoDot:3
+22 SET USELECT(LI)=$$SELECT(8930,"Select the user class: ")
+23 IF USELECT(LI)=-1
SET USELDONE=1
End DoDot:3
QUIT
+24 IF LVLLIST(LI)="USER"
Begin DoDot:3
+25 SET USELECT(LI)=$$SELECT(200,"Select the user: ")
+26 IF USELECT(LI)=-1
SET USELDONE=1
End DoDot:3
QUIT
+27 IF LVLLIST(LI)="CPRS"
Begin DoDot:3
+28 SET USELECT("CPRS","USER")=$$SELECT(200,"Select the user: ")
+29 IF USELECT("CPRS","USER")=-1
SET USELDONE=1
QUIT
+30 SET USELECT("CPRS","LOCATION")=$$SELECT(44,"Select the location: ")
+31 IF USELECT("CPRS","LOCATION")=-1
SET USELDONE=1
End DoDot:3
QUIT
End DoDot:2
+32 IF USELDONE=1
QUIT
+33 IF NEWRP
DO NEWPARAM(.LVLLIST,.SELLIST,.USELECT,.REMLIST)
+34 IF 'NEWRP
DO OLDPARAM(.LVLLIST,.SELLIST,.USELECT,.REMLIST)
+35 KILL REMLIST("IEN")
+36 ;Produce the report.
+37 DO REPORT(NEWRP,.LVLLIST,.SELLIST,.USELECT,.REMLIST)
End DoDot:1
+38 QUIT
+39 ;
+40 ;==============================
REPORT(NEWRP,LVLLIST,SELLIST,USELECT,REMLIST) ;Generate the report.
+1 NEW BOP,FIRST,IEN,IND,NDEF,NL,LEVELS,LI,OUTPUT,SELECT,TEMP
+2 SET NL=0
+3 SET NL=NL+1
SET OUTPUT(NL)="Report Criteria"
+4 SET NL=NL+1
SET OUTPUT(NL)="Use new cover sheet parameters: "_$SELECT(NEWRP=1:"YES",1:"NO")
+5 SET NL=NL+1
SET OUTPUT(NL)="Selected levels:"
+6 SET LI=0
+7 FOR
SET LI=$ORDER(SELLIST(LI))
if LI=""
QUIT
Begin DoDot:1
+8 SET NL=NL+1
SET OUTPUT(NL)=" "_LVLLIST(LI)
+9 SET SELECT=$GET(USELECT(LI))
+10 IF SELECT=-1
SET NL=NL+1
SET OUTPUT(NL)=" Value - No selection"
+11 IF $PIECE(SELECT,U,2)'=""
SET NL=NL+1
SET OUTPUT(NL)=" Value - "_$PIECE(SELECT,U,2)
+12 IF LVLLIST(LI)="CPRS"
Begin DoDot:2
+13 SET NL=NL+1
SET OUTPUT(NL)=" User - "_$PIECE(USELECT("CPRS","USER"),U,2)
+14 SET NL=NL+1
SET OUTPUT(NL)=" Location - "_$PIECE(USELECT("CPRS","LOCATION"),U,2)
+15 IF 'NEWRP
QUIT
+16 SET NL=NL+1
SET OUTPUT(NL)=" Service - "_USELECT("CPRS","SERVICE")
+17 SET IND=0
+18 FOR
SET IND=$ORDER(USELECT("CPRS","USER CLASS",IND))
if IND=""
QUIT
Begin DoDot:3
+19 SET NL=NL+1
SET OUTPUT(NL)=" User Class - "_USELECT("CPRS","USER CLASS",IND)
End DoDot:3
End DoDot:2
End DoDot:1
+20 SET NL=NL+1
SET OUTPUT(NL)=""
+21 SET FIRST=$ORDER(SELLIST(0))
+22 SET LEVELS=""
SET LI=0
+23 FOR
SET LI=$ORDER(SELLIST(LI))
if LI=""
QUIT
Begin DoDot:1
+24 SET NL=NL+1
SET OUTPUT(NL)=""
+25 IF NEWRP
Begin DoDot:2
+26 IF LI>FIRST
SET LEVELS=LEVELS_","
+27 SET LEVELS=LEVELS_" "_LVLLIST(LI)
+28 SET NL=NL+1
SET OUTPUT(NL)="Reminder list at"_LEVELS
+29 SET OUTPUT(NL)=OUTPUT(NL)_$SELECT(LI=FIRST:" level",1:" levels")
End DoDot:2
+30 IF 'NEWRP
Begin DoDot:2
+31 SET LEVELS=LVLLIST(LI)
+32 SET NL=NL+1
SET OUTPUT(NL)="Reminder list at the "_LEVELS_" level"
End DoDot:2
+33 SET IND=0
+34 FOR
SET IND=+$ORDER(REMLIST(LVLLIST(LI),"LIST",IND))
if IND=0
QUIT
Begin DoDot:2
+35 SET NL=NL+1
SET OUTPUT(NL)="LIST("_IND_")="_REMLIST(LVLLIST(LI),"LIST",IND)
End DoDot:2
+36 SET IND=""
SET NDEF=0
+37 SET NL=NL+1
SET OUTPUT(NL)=""
+38 SET NL=NL+1
SET OUTPUT(NL)="Reminders in Display Order"
+39 FOR
SET IND=$ORDER(REMLIST(LVLLIST(LI),"REM",IND))
if IND=""
QUIT
Begin DoDot:2
+40 SET NDEF=NDEF+1
+41 SET IEN=REMLIST(LVLLIST(LI),"REM",IND)
+42 SET TEMP=^PXD(811.9,IEN,0)
+43 IF NDEF>1
SET NL=NL+1
SET OUTPUT(NL)=""
+44 SET NL=NL+1
SET OUTPUT(NL)="Name - "_$PIECE(TEMP,U,1)_" (IEN="_IEN_")"
+45 SET NL=NL+1
SET OUTPUT(NL)="Print Name - "_$PIECE(TEMP,U,3)
End DoDot:2
+46 SET NL=NL+1
SET OUTPUT(NL)=""
+47 SET NL=NL+1
SET OUTPUT(NL)="There are "_NDEF_" reminders on the list."
End DoDot:1
+48 IF 'NEWRP
IF '$DATA(REMLIST("CPRS"))
Begin DoDot:1
+49 SET NL=NL+1
SET OUTPUT(NL)=""
+50 SET NL=NL+1
SET OUTPUT(NL)="Final Reminder List"
+51 SET IND=0
SET NDEF=0
+52 FOR
SET IND=+$ORDER(REMLIST(IND))
if IND=0
QUIT
Begin DoDot:2
+53 SET NDEF=NDEF+1
+54 SET IEN=REMLIST(IND)
+55 SET TEMP=^PXD(811.9,IEN,0)
+56 IF NDEF>1
SET NL=NL+1
SET OUTPUT(NL)=""
+57 SET NL=NL+1
SET OUTPUT(NL)="Name - "_$PIECE(TEMP,U,1)
+58 SET NL=NL+1
SET OUTPUT(NL)="Print Name - "_$PIECE(TEMP,U,3)
End DoDot:2
+59 SET NL=NL+1
SET OUTPUT(NL)=""
+60 SET NL=NL+1
SET OUTPUT(NL)="There are "_NDEF_" reminders on the list."
+61 SET NL=NL+1
SET OUTPUT(NL)=""
End DoDot:1
+62 SET BOP=$$BORP^PXRMUTIL("B")
+63 IF BOP="B"
Begin DoDot:1
+64 SET X="IORESET"
+65 DO ENDR^%ZISS
+66 DO BROWSE^DDBR("OUTPUT","NR","CPRS Cover Sheet Reminder List")
+67 WRITE IORESET
+68 DO KILL^%ZISS
End DoDot:1
+69 IF BOP="P"
DO GPRINT^PXRMUTIL("OUTPUT")
+70 QUIT
+71 ;
+72 ;==============================
SELECT(FILENUM,PROMPT) ;Let the user make a selection.
+1 NEW DIC,DONE,X,Y
+2 SET DIC=FILENUM
SET DIC(0)="AEO"
+3 SET DIC("A")=PROMPT
+4 SET DONE=0
+5 FOR
if DONE
QUIT
Begin DoDot:1
+6 DO ^DIC
+7 IF X'=""
SET DONE=1
End DoDot:1
+8 QUIT Y
+9 ;
+10 ;==============================
SELLIST(NEWRP,LVLLIST,OLIST) ;Build a list of selections and let the user
+1 ;select from the list.
+2 NEW CPRSLVL,DIR,DIROUT,DIRUT,DTOUT,DUOUT,IND,NLVL,SELLIST,X,Y
+3 KILL OLIST
+4 SET NLVL=0
+5 SET NLVL=NLVL+1
SET SELLIST(NLVL)=" "_$JUSTIFY(NLVL,4)_" - PACKAGE"
SET LVLLIST(NLVL)="PACKAGE"
+6 SET NLVL=NLVL+1
SET SELLIST(NLVL)=" "_$JUSTIFY(NLVL,4)_" - SYSTEM"
SET LVLLIST(NLVL)="SYSTEM"
+7 SET NLVL=NLVL+1
SET SELLIST(NLVL)=" "_$JUSTIFY(NLVL,4)_" - DIVISION"
SET LVLLIST(NLVL)="DIVISION"
+8 SET NLVL=NLVL+1
SET SELLIST(NLVL)=" "_$JUSTIFY(NLVL,4)_" - SERVICE"
SET LVLLIST(NLVL)="SERVICE"
+9 SET NLVL=NLVL+1
SET SELLIST(NLVL)=" "_$JUSTIFY(NLVL,4)_" - LOCATION"
SET LVLLIST(NLVL)="LOCATION"
+10 IF NEWRP
SET NLVL=NLVL+1
SET SELLIST(NLVL)=" "_$JUSTIFY(NLVL,4)_" - USER CLASS"
SET LVLLIST(NLVL)="USER CLASS"
+11 SET NLVL=NLVL+1
SET SELLIST(NLVL)=" "_$JUSTIFY(NLVL,4)_" - USER"
SET LVLLIST(NLVL)="USER"
+12 SET NLVL=NLVL+1
SET SELLIST(NLVL)=" "_$JUSTIFY(NLVL,4)_" - CPRS"
SET LVLLIST(NLVL)="CPRS"
+13 SET CPRSLVL=NLVL
+14 MERGE DIR("A")=SELLIST
+15 SET DIR("A")="Enter your list for the report"
+16 SET DIR(0)="LO^1:"_NLVL
+17 WRITE !!,"Select from the following levels:"
+18 DO ^DIR
+19 IF $DATA(DIROUT)!$DATA(DIRUT)
KILL OLIST
QUIT
+20 IF $DATA(DUOUT)!$DATA(DTOUT)
KILL OLIST
QUIT
+21 ;If the list contains CPRS only return CPRS.
+22 IF Y[CPRSLVL
SET Y=CPRSLVL_","
+23 ;Make sure the list is ordered.
+24 FOR IND=1:1:$LENGTH(Y,",")-1
SET OLIST($PIECE(Y,",",IND))=""
+25 QUIT
+26 ;
