PXRMLCR ; SLC/PJH - Create Patient List from individual finding rule; 04/15/2014
;;2.0;CLINICAL REMINDERS;**4,6,12,26**;Feb 04, 2005;Build 404
;
; Called from PXRM PATIENT LIST CREATE protocol
;
START N BEG,DUOUT,DTOUT,END,LIT,PXRMDPAT,PXRMLIST,PXRMNODE,PXRMRULE,PXRMTPAT
;Check if evaluation is disabled.
I $D(^XTMP("PXRM_DISEV",0)) D Q
. W !,"Reminder evaluation is disabled, cannot start patient list building."
. H 2
;
N TEXT
;Initialise
K ^TMP("PXRMLCR",$J)
;Node for ^TMP lists created in PXRMRULE
S PXRMNODE="PXRMRULE",LIT="Patient List"
;Reset screen mode
W IORESET
;Set prompt text
S TEXT="Select PATIENT LIST name: "
;Select Patient List
LIST D PLIST(.PXRMLIST,TEXT,"") I $D(DUOUT)!$D(DTOUT) D Q
. I $G(PXRMLIST)="" Q
. I $P($G(^PXRMXP(810.5,PXRMLIST,0)),U,4)'="" Q
. N DIK
. S DA=PXRMLIST,DIK="^PXRMXP(810.5," D ^DIK
;
SECURE ;option to secure the list
K PATCREAT
I $D(PATCREAT)=0 S PATCREAT="N" D ASK^PXRMXD(.PATCREAT,"Secure list?: ",2) Q:$D(DTOUT) G:$D(DUOUT) START
;
PURGE ;Option to purge the list
K PLISTPUG
S PLISTPUG="N" D ASK^PXRMXD(.PLISTPUG,"Purge Patient List after 5 years?: ",5) Q:$D(DTOUT) G:$D(DUOUT) SECURE
;Select rule set.
RULE D LRULE(.PXRMRULE) Q:$D(DTOUT) G:$D(DUOUT) LIST
;Select Date Range
DATE D DATES^PXRMEUT(.BEG,.END,LIT) Q:$D(DTOUT) G:$D(DUOUT) RULE
;
;Ask whether to include deceased and test patients.
DPAT S PXRMDPAT=$$ASKYN^PXRMEUT("N","Include deceased patients on the list")
Q:$D(DTOUT) G:$D(DUOUT) DATE
TPAT S PXRMTPAT=$$ASKYN^PXRMEUT("N","Include test patients on the list")
Q:$D(DTOUT) G:$D(DUOUT) DPAT
I $G(PXRMDEBG) D RUN^PXRMLCR(PXRMRULE,PXRMLIST,PXRMNODE,BEG,END,PXRMDPAT,PXRMTPAT) Q
;Build patient list in background
N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
S ZTDESC="Build Reminder Patient List"
S ZTRTN="RUN^PXRMLCR(PXRMRULE,PXRMLIST,PXRMNODE,BEG,END,PXRMDPAT,PXRMTPAT)"
S ZTSAVE("BEG")=""
S ZTSAVE("END")=""
S ZTSAVE("PATCREAT")=""
S ZTSAVE("PXRMDPAT")=""
S ZTSAVE("PXRMLIST")=""
S ZTSAVE("PXRMNODE")=""
S ZTSAVE("PXRMRULE")=""
S ZTSAVE("PXRMTPAT")=""
S ZTSAVE("PLISTPUG")=""
S ZTIO=""
;
;Select and verify start date/time for task
N DIR,DTOUT,DUOUT,MINDT,SDTIME,STIME,X,Y
S MINDT=$$NOW^XLFDT
W !,"Queue the "_ZTDESC_" for "_$P($G(^PXRMXP(810.5,PXRMLIST,0)),U)_": "
S DIR("A",1)="Enter the date and time you want the job to start."
S DIR("A",2)="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")
S DIR("A")="Start the task at: "
S DIR(0)="DAU"_U_MINDT_"::RSX"
D ^DIR
I $D(DTOUT)!$D(DUOUT) Q
S SDTIME=Y
;
;Put the task into the queue.
S ZTDTH=SDTIME
D ^%ZTLOAD
W !,"Task number ",ZTSK," queued." H 2
EXIT Q
;
HELP(CALL) ;General help text routine
N HTEXT
I CALL=1 D
.S HTEXT(1)="Enter 'Y' to overwrite this existing list. Enter 'N' to"
.S HTEXT(2)="use a different patient list name."
;
I CALL=2 D
.S HTEXT(1)="Enter 'Y' to make the list private or 'N' to make it public."
.S HTEXT(2)="You can give other users access to your private lists in the Patient List Menu screens."
;
I CALL=3 D
.S HTEXT(1)="Enter Y to save the patient to a Reminder Patient List. Enter N to not save the output."
;
I CALL=4 D
.S HTEXT(1)="Enter Y to turn on debug output."
.S HTEXT(2)="The debug output will send a series of MailMan messages to the requestor of the report"
.S HTEXT(3)="-**WARNING**- the reminder report will take longer to run if you turn on this option!"
D HELP^PXRMEUT(.HTEXT)
Q
;
PLIST(LIST,TEXT,IENO) ;Select Patient List
N X,Y,DIC,DLAYGO
PL1 S DIC=810.5,DLAYGO=DIC,DIC(0)="QAEMZL"
S DIC("A")=TEXT
S DIC("S")="I $P($G(^(100)),U)'=""N"""
;If this is a new entry save the creator, make the TYPE public and
;CLASS local.
S DIC("DR")=".07///`"_DUZ_";.08///PUB;100///L"
W !
D ^DIC
I X="" W !,"A patient list name must be entered" G PL1
I X=(U_U) S DTOUT=1
I Y=-1 S DUOUT=1
I $D(DTOUT)!$D(DUOUT) Q
;
;I copy mode dissallow copy to same list
I IENO=$P(Y,U) W !,"A patient list cannot be copied to itself." G PL1
;
I ($P(Y,U,3)=1) S LIST=$P(Y,U) Q
;Check if OK to overwrite
N OWRITE
S OWRITE=$$ASKYN^PXRMEUT("N","Okay to overwrite "_$P(Y,U,2),"PXRMLCR",1)
Q:$D(DTOUT) G:$D(DUOUT)!('OWRITE) PL1
S OWRITE=$$LDELOK^PXRMEUT($P(Y,U,1))
I 'OWRITE D G PL1
. W !,"In order to overwrite a list you must be the creator or a Reminder Manager!"
;Return list ien
S LIST=$P(Y,U)
Q
;
LRULE(RULE) ;Select List Rule
N X,Y,DIC
LR1 S DIC=810.4,DIC(0)="QAEMZ"
S DIC("A")="Select LIST RULE SET: "
;Only allow rule sets with components
S DIC("S")="I $P(^(0),U,3)=3"
W !
D ^DIC
I X="" W !,"A list rule set name must be entered" G LR1
I X=(U_U) S DTOUT=1
I Y=-1 S DUOUT=1
I $D(DTOUT)!$D(DUOUT) Q
;Return rule ien
S RULE=$P(Y,U)
;Check that rule set is valid
N ERROR,LR,LRTYPE,NL,OP,SEQ,SUB,TEMP,TEXT
S SUB=$O(^PXRM(810.4,RULE,30,0))
I SUB="" W !,"Rule set has no component rules" G LR1
S (ERROR,SUB)=0,NL=1
F S SUB=$O(^PXRM(810.4,RULE,30,SUB)) Q:'SUB D Q:ERROR
.S TEMP=$G(^PXRM(810.4,RULE,30,SUB,0))
.S SEQ=$P(TEMP,U,1),LR=$P(TEMP,U,2),OP=$P(TEMP,U,3)
.I SEQ="" S NL=NL+1,TEXT(NL)=" Sequence is missing.",ERROR=1
.I LR="" S NL=NL+1,TEXT(NL)=" List rule is missing.",ERROR=1
.I OP="" S NL=NL+1,TEXT(NL)=" Operation is missing.",ERROR=1
.;The Insert operation can only be used with finding rules.
.I OP="F",LR'="" D
..S LRTYPE=$P(^PXRM(810.4,LR,0),U,3)
..I LRTYPE'=1 S NL=NL+1,TEXT(NL)=" Insert operation can only be used with finding rules.",ERROR=1
I ERROR D G LR1
.S TEXT(1)="The rule set is incomplete or incorrect:"
.D EN^DDIOL(.TEXT)
Q
;
;Build list and clear ^TMP files
RUN(PXRMRULE,PXRMLIST,PXRMNODE,BEG,END,PXRMDPAT,PXRMTPAT) ;
;Process rule set and update final patient list
D START^PXRMRULE(PXRMRULE,PXRMLIST,PXRMNODE,BEG,END,"","","",PXRMDPAT,PXRMTPAT,"")
;Clear ^TMP lists created for rule
D CLEAR^PXRMRULE(PXRMRULE,PXRMNODE)
Q
;
REMOVE(IEN) ;
S $P(^PXRM(810.4,IEN,0),U,10)=""
Q "@1"
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMLCR 6052 printed Oct 16, 2024@17:47:12 Page 2
PXRMLCR ; SLC/PJH - Create Patient List from individual finding rule; 04/15/2014
+1 ;;2.0;CLINICAL REMINDERS;**4,6,12,26**;Feb 04, 2005;Build 404
+2 ;
+3 ; Called from PXRM PATIENT LIST CREATE protocol
+4 ;
START NEW BEG,DUOUT,DTOUT,END,LIT,PXRMDPAT,PXRMLIST,PXRMNODE,PXRMRULE,PXRMTPAT
+1 ;Check if evaluation is disabled.
+2 IF $DATA(^XTMP("PXRM_DISEV",0))
Begin DoDot:1
+3 WRITE !,"Reminder evaluation is disabled, cannot start patient list building."
+4 HANG 2
End DoDot:1
QUIT
+5 ;
+6 NEW TEXT
+7 ;Initialise
+8 KILL ^TMP("PXRMLCR",$JOB)
+9 ;Node for ^TMP lists created in PXRMRULE
+10 SET PXRMNODE="PXRMRULE"
SET LIT="Patient List"
+11 ;Reset screen mode
+12 WRITE IORESET
+13 ;Set prompt text
+14 SET TEXT="Select PATIENT LIST name: "
+15 ;Select Patient List
LIST DO PLIST(.PXRMLIST,TEXT,"")
IF $DATA(DUOUT)!$DATA(DTOUT)
Begin DoDot:1
+1 IF $GET(PXRMLIST)=""
QUIT
+2 IF $PIECE($GET(^PXRMXP(810.5,PXRMLIST,0)),U,4)'=""
QUIT
+3 NEW DIK
+4 SET DA=PXRMLIST
SET DIK="^PXRMXP(810.5,"
DO ^DIK
End DoDot:1
QUIT
+5 ;
SECURE ;option to secure the list
+1 KILL PATCREAT
+2 IF $DATA(PATCREAT)=0
SET PATCREAT="N"
DO ASK^PXRMXD(.PATCREAT,"Secure list?: ",2)
if $DATA(DTOUT)
QUIT
if $DATA(DUOUT)
GOTO START
+3 ;
PURGE ;Option to purge the list
+1 KILL PLISTPUG
+2 SET PLISTPUG="N"
DO ASK^PXRMXD(.PLISTPUG,"Purge Patient List after 5 years?: ",5)
if $DATA(DTOUT)
QUIT
if $DATA(DUOUT)
GOTO SECURE
+3 ;Select rule set.
RULE DO LRULE(.PXRMRULE)
if $DATA(DTOUT)
QUIT
if $DATA(DUOUT)
GOTO LIST
+1 ;Select Date Range
DATE DO DATES^PXRMEUT(.BEG,.END,LIT)
if $DATA(DTOUT)
QUIT
if $DATA(DUOUT)
GOTO RULE
+1 ;
+2 ;Ask whether to include deceased and test patients.
DPAT SET PXRMDPAT=$$ASKYN^PXRMEUT("N","Include deceased patients on the list")
+1 if $DATA(DTOUT)
QUIT
if $DATA(DUOUT)
GOTO DATE
TPAT SET PXRMTPAT=$$ASKYN^PXRMEUT("N","Include test patients on the list")
+1 if $DATA(DTOUT)
QUIT
if $DATA(DUOUT)
GOTO DPAT
+2 IF $GET(PXRMDEBG)
DO RUN^PXRMLCR(PXRMRULE,PXRMLIST,PXRMNODE,BEG,END,PXRMDPAT,PXRMTPAT)
QUIT
+3 ;Build patient list in background
+4 NEW ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
+5 SET ZTDESC="Build Reminder Patient List"
+6 SET ZTRTN="RUN^PXRMLCR(PXRMRULE,PXRMLIST,PXRMNODE,BEG,END,PXRMDPAT,PXRMTPAT)"
+7 SET ZTSAVE("BEG")=""
+8 SET ZTSAVE("END")=""
+9 SET ZTSAVE("PATCREAT")=""
+10 SET ZTSAVE("PXRMDPAT")=""
+11 SET ZTSAVE("PXRMLIST")=""
+12 SET ZTSAVE("PXRMNODE")=""
+13 SET ZTSAVE("PXRMRULE")=""
+14 SET ZTSAVE("PXRMTPAT")=""
+15 SET ZTSAVE("PLISTPUG")=""
+16 SET ZTIO=""
+17 ;
+18 ;Select and verify start date/time for task
+19 NEW DIR,DTOUT,DUOUT,MINDT,SDTIME,STIME,X,Y
+20 SET MINDT=$$NOW^XLFDT
+21 WRITE !,"Queue the "_ZTDESC_" for "_$PIECE($GET(^PXRMXP(810.5,PXRMLIST,0)),U)_": "
+22 SET DIR("A",1)="Enter the date and time you want the job to start."
+23 SET DIR("A",2)="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")
+24 SET DIR("A")="Start the task at: "
+25 SET DIR(0)="DAU"_U_MINDT_"::RSX"
+26 DO ^DIR
+27 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+28 SET SDTIME=Y
+29 ;
+30 ;Put the task into the queue.
+31 SET ZTDTH=SDTIME
+32 DO ^%ZTLOAD
+33 WRITE !,"Task number ",ZTSK," queued."
HANG 2
EXIT QUIT
+1 ;
HELP(CALL) ;General help text routine
+1 NEW HTEXT
+2 IF CALL=1
Begin DoDot:1
+3 SET HTEXT(1)="Enter 'Y' to overwrite this existing list. Enter 'N' to"
+4 SET HTEXT(2)="use a different patient list name."
End DoDot:1
+5 ;
+6 IF CALL=2
Begin DoDot:1
+7 SET HTEXT(1)="Enter 'Y' to make the list private or 'N' to make it public."
+8 SET HTEXT(2)="You can give other users access to your private lists in the Patient List Menu screens."
End DoDot:1
+9 ;
+10 IF CALL=3
Begin DoDot:1
+11 SET HTEXT(1)="Enter Y to save the patient to a Reminder Patient List. Enter N to not save the output."
End DoDot:1
+12 ;
+13 IF CALL=4
Begin DoDot:1
+14 SET HTEXT(1)="Enter Y to turn on debug output."
+15 SET HTEXT(2)="The debug output will send a series of MailMan messages to the requestor of the report"
+16 SET HTEXT(3)="-**WARNING**- the reminder report will take longer to run if you turn on this option!"
End DoDot:1
+17 DO HELP^PXRMEUT(.HTEXT)
+18 QUIT
+19 ;
PLIST(LIST,TEXT,IENO) ;Select Patient List
+1 NEW X,Y,DIC,DLAYGO
PL1 SET DIC=810.5
SET DLAYGO=DIC
SET DIC(0)="QAEMZL"
+1 SET DIC("A")=TEXT
+2 SET DIC("S")="I $P($G(^(100)),U)'=""N"""
+3 ;If this is a new entry save the creator, make the TYPE public and
+4 ;CLASS local.
+5 SET DIC("DR")=".07///`"_DUZ_";.08///PUB;100///L"
+6 WRITE !
+7 DO ^DIC
+8 IF X=""
WRITE !,"A patient list name must be entered"
GOTO PL1
+9 IF X=(U_U)
SET DTOUT=1
+10 IF Y=-1
SET DUOUT=1
+11 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+12 ;
+13 ;I copy mode dissallow copy to same list
+14 IF IENO=$PIECE(Y,U)
WRITE !,"A patient list cannot be copied to itself."
GOTO PL1
+15 ;
+16 IF ($PIECE(Y,U,3)=1)
SET LIST=$PIECE(Y,U)
QUIT
+17 ;Check if OK to overwrite
+18 NEW OWRITE
+19 SET OWRITE=$$ASKYN^PXRMEUT("N","Okay to overwrite "_$PIECE(Y,U,2),"PXRMLCR",1)
+20 if $DATA(DTOUT)
QUIT
if $DATA(DUOUT)!('OWRITE)
GOTO PL1
+21 SET OWRITE=$$LDELOK^PXRMEUT($PIECE(Y,U,1))
+22 IF 'OWRITE
Begin DoDot:1
+23 WRITE !,"In order to overwrite a list you must be the creator or a Reminder Manager!"
End DoDot:1
GOTO PL1
+24 ;Return list ien
+25 SET LIST=$PIECE(Y,U)
+26 QUIT
+27 ;
LRULE(RULE) ;Select List Rule
+1 NEW X,Y,DIC
LR1 SET DIC=810.4
SET DIC(0)="QAEMZ"
+1 SET DIC("A")="Select LIST RULE SET: "
+2 ;Only allow rule sets with components
+3 SET DIC("S")="I $P(^(0),U,3)=3"
+4 WRITE !
+5 DO ^DIC
+6 IF X=""
WRITE !,"A list rule set name must be entered"
GOTO LR1
+7 IF X=(U_U)
SET DTOUT=1
+8 IF Y=-1
SET DUOUT=1
+9 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+10 ;Return rule ien
+11 SET RULE=$PIECE(Y,U)
+12 ;Check that rule set is valid
+13 NEW ERROR,LR,LRTYPE,NL,OP,SEQ,SUB,TEMP,TEXT
+14 SET SUB=$ORDER(^PXRM(810.4,RULE,30,0))
+15 IF SUB=""
WRITE !,"Rule set has no component rules"
GOTO LR1
+16 SET (ERROR,SUB)=0
SET NL=1
+17 FOR
SET SUB=$ORDER(^PXRM(810.4,RULE,30,SUB))
if 'SUB
QUIT
Begin DoDot:1
+18 SET TEMP=$GET(^PXRM(810.4,RULE,30,SUB,0))
+19 SET SEQ=$PIECE(TEMP,U,1)
SET LR=$PIECE(TEMP,U,2)
SET OP=$PIECE(TEMP,U,3)
+20 IF SEQ=""
SET NL=NL+1
SET TEXT(NL)=" Sequence is missing."
SET ERROR=1
+21 IF LR=""
SET NL=NL+1
SET TEXT(NL)=" List rule is missing."
SET ERROR=1
+22 IF OP=""
SET NL=NL+1
SET TEXT(NL)=" Operation is missing."
SET ERROR=1
+23 ;The Insert operation can only be used with finding rules.
+24 IF OP="F"
IF LR'=""
Begin DoDot:2
+25 SET LRTYPE=$PIECE(^PXRM(810.4,LR,0),U,3)
+26 IF LRTYPE'=1
SET NL=NL+1
SET TEXT(NL)=" Insert operation can only be used with finding rules."
SET ERROR=1
End DoDot:2
End DoDot:1
if ERROR
QUIT
+27 IF ERROR
Begin DoDot:1
+28 SET TEXT(1)="The rule set is incomplete or incorrect:"
+29 DO EN^DDIOL(.TEXT)
End DoDot:1
GOTO LR1
+30 QUIT
+31 ;
+32 ;Build list and clear ^TMP files
RUN(PXRMRULE,PXRMLIST,PXRMNODE,BEG,END,PXRMDPAT,PXRMTPAT) ;
+1 ;Process rule set and update final patient list
+2 DO START^PXRMRULE(PXRMRULE,PXRMLIST,PXRMNODE,BEG,END,"","","",PXRMDPAT,PXRMTPAT,"")
+3 ;Clear ^TMP lists created for rule
+4 DO CLEAR^PXRMRULE(PXRMRULE,PXRMNODE)
+5 QUIT
+6 ;
REMOVE(IEN) ;
+1 SET $PIECE(^PXRM(810.4,IEN,0),U,10)=""
+2 QUIT "@1"
+3 ;
