- 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 Jan 18, 2025@02:47:35 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 ;