PXRMLPU ; SLC/PKR/PJH - Reminder Patient List ;10/11/2007
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
;
;Main entry point for PXRM PATIENT LIST
START(MODE) ;
N PXRMDONE,VALMBCK,VALMSG,X,XMZ,MODE1
S X="IORESET"
D ENDR^%ZISS
S VALMCNT=0
D EN^VALM("PXRM PATIENT LIST USER")
W IORESET
D KILL^%ZISS
Q
;
ACCESS(IEN,NODE) ;
;Holders of the PXRM MANAGER key have full access to all lists.
;DBIA #10076
I $D(^XUSEC("PXRM MANAGER",DUZ)) Q "F"
N ACCESS,TYPE
I $G(NODE)="" S NODE=$G(^PXRMXP(810.5,IEN,0))
S TYPE=$P(NODE,U,8)
I TYPE="" Q "F"
I TYPE="PUB" Q "F"
I $P(NODE,U,7)=DUZ Q "F"
S ACCESS="N"
I TYPE="PVT",$D(^PXRMXP(810.5,IEN,40,"B",DUZ)) D
. N USIEN,STATUS
. S USIEN=$O(^PXRMXP(810.5,IEN,40,"B",DUZ,""))
. S ACCESS=$S(USIEN="":"N",1:$P(^PXRMXP(810.5,IEN,40,USIEN,0),U,2))
Q ACCESS
;
BLDLIST ;
N PLIST
K ^TMP("PXRMLPU",$J)
K ^TMP("PXRMLPUH",$J)
S PLIST="PXRMLPU"
D LIST(MODE,PLIST)
S VALMCNT=+$G(^TMP("PXRMLPU",$J,"VALMCNT"))
Q
;
ENTRY ;Entry code
;MODE=0 ORDER BY NAME
;MODE=1 ORDER BY TYPE
I $G(MODE)'>0 S MODE=0
D BLDLIST,XQORM
Q
;
EXIT ;Exit code
K ^TMP("PXRMLPU",$J)
K ^TMP("PXRMLPUH",$J)
D CLEAN^VALM10
D FULL^VALM1
S VALMBCK="R"
Q
;
HDR ; Header code
N NAME
S VALMHDR(1)="Available Patient Lists."
Q
;
HELP(CALL) ;General help text routine
N HTEXT
I CALL=1 D
.S HTEXT(1)="Select CO to copy the patient list.\\"
.S HTEXT(2)="Select COE to copy the patient list to an OE/RR Team.\\"
.S HTEXT(3)="Select DE to delete the patient list.\\"
.S HTEXT(4)="Select DCD to display creation documentation.\\"
.S HTEXT(5)="Select DSP to display the patient list.\\"
D HELP^PXRMEUT(.HTEXT)
Q
;
HLP ;Help code
N ORU,ORUPRMT,SUB,XQORM
S SUB="PXRMLPUH"
D EN^VALM("PXRM PATIENT LIST HELP")
Q
;
INIT ;Init
S VALMCNT=0
Q
;
LIST(MODE,PLIST) ;Build a list of patient list entries.
N ACCESS,COUNT,DATA,DATE,IND,FMTSTR,FNAME,OUTPUT,NAME,NL,NUM
N STR,SUB,TYPE
S FMTSTR=$$LMFMTSTR^PXRMTEXT(.VALMDDF,"RLLRRC")
;MODE=0 build list in alphabetical order
;MODE=1 build list by type of list.
K ^TMP($J,PLIST),^TMP(PLIST,$J)
S VALMCNT=0,NAME="",NUM=0,TYPE=""
F S NAME=$O(^PXRMXP(810.5,"B",NAME)) Q:NAME="" D
.S IND="" F S IND=$O(^PXRMXP(810.5,"B",NAME,IND)) Q:'IND D
..S DATA=$G(^PXRMXP(810.5,IND,0))
..S ACCESS=$$ACCESS(IND,DATA)
..I ACCESS="N" Q
..S FNAME=$P($G(DATA),U),DATE=$P($G(DATA),U,4)
..S COUNT=+$P($G(^PXRMXP(810.5,IND,30,0)),U,4)
..S TYPE=$P(DATA,U,8)
..S SUB=$S(MODE=0:"NAME",1:TYPE)
..S ^TMP($J,PLIST,SUB,FNAME)=IND_U_DATE_U_COUNT_U_TYPE_U_ACCESS
I '$D(^TMP($J,PLIST)) Q
;Loop through ARRAY to populate the output list
;sub is either the type of list or 'NAME'. If sort is
;by TYPE show PVT lists first.
S SUB=""
F S SUB=$O(^TMP($J,PLIST,SUB),-1) Q:SUB="" D
. S FNAME=""
. F S FNAME=$O(^TMP($J,PLIST,SUB,FNAME)) Q:FNAME="" D
.. S DATA=^TMP($J,PLIST,SUB,FNAME),NUM=NUM+1
.. S ^TMP("PXRMLPU",$J,"SEL",NUM)=$P(DATA,U,1)
.. S DATE=$P(DATA,U,2),DATE=$$FMTE^XLFDT(DATE,2)
.. S $P(DATA,U,2)=DATE
.. S STR=NUM_U_FNAME_U_$P(DATA,U,2,5)
.. D COLFMT^PXRMTEXT(FMTSTR,STR," ",.NL,.OUTPUT)
.. F IND=1:1:NL D
... S VALMCNT=VALMCNT+1,^TMP(PLIST,$J,VALMCNT,0)=OUTPUT(IND)
... S ^TMP("PXRMLPU",$J,"IDX",VALMCNT,NUM)=""
S ^TMP(PLIST,$J,"VALMCNT")=VALMCNT
K ^TMP($J,PLIST)
Q
;
PCOPY ;Patient list copy
S SUB="PXRMLPU"
D PCOPY1(SUB)
D BLDLIST
S VALMBCK="R"
Q
;
PCOPY1(SUB) ;
;Full Screen
W IORESET
N IND,LISTIEN,VALMY
D EN^VALM2(XQORNOD(0))
;If there is no list quit.
I '$D(VALMY) Q
S IND="",PXRMDONE=0
F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D
.;Get the patient list ien.
.S LISTIEN=^TMP(SUB,$J,"SEL",IND)
.D COPY^PXRMRUL1(LISTIEN)
Q
;
PDELETE ;Patient list delete
;Full Screen
W IORESET
N DELOK,IND,LISTIEN,NODE,VALMY
D EN^VALM2(XQORNOD(0))
;If there is no list quit.
I '$D(VALMY) Q
S IND="",PXRMDONE=0
F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D
.;Get the patient list ien.
.S LISTIEN=^TMP("PXRMLPU",$J,"SEL",IND)
.S NODE=$G(^PXRMXP(810.5,LISTIEN,0))
.S DELOK=$$LDELOK^PXRMEUT(LISTIEN)
.I DELOK D DELETE^PXRMRUL1(LISTIEN) Q
.E D Q
..W !,"In order to delete a list you must be the creator or a Reminder Manager!"
..S PXRMDONE=1 H 2
D BLDLIST
S VALMBCK="R"
Q
;
PEXIT ;Protocol exit code
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
;Reset after page up/down etc
D XQORM
Q
;
POERR ;Patient list copy to OERR Team (#101.21)
;Full Screen
W IORESET
N ACCESS,IND,LISTIEN,NODE,USIEN,VALMY
D EN^VALM2(XQORNOD(0))
;If there is no list quit.
I '$D(VALMY) Q
S IND="",PXRMDONE=0
F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D
.;Get the patient list ien.
.S LISTIEN=^TMP("PXRMLPU",$J,"SEL",IND)
.S NODE=$G(^PXRMXP(810.5,LISTIEN,0))
.S ACCESS=$$ACCESS^PXRMLPU(LISTIEN,NODE)
.I ACCESS="F" D OERR^PXRMLPOE(LISTIEN)
.I ACCESS="N" D
..W !,"The list cannot be copied; you must have full access to copy the list to an OE/RR team!"
..S PXRMDONE=1 H 2
S VALMBCK="R"
Q
;
PLIST ;Patient list inquiry.
N CREAT,NAME,IND,LISTIEN,USIEN,VALMY,CREAT,NODE,TRUE
D EN^VALM2(XQORNOD(0))
;If there is no list quit.
I '$D(VALMY) Q
;PXRMDONE is newed in PXRMLPU
S PXRMDONE=0
S IND=""
F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D
.S LISTIEN=^TMP("PXRMLPU",$J,"SEL",IND)
.D START^PXRMLPP(LISTIEN)
D BLDLIST
S VALMBCK="R"
Q
;
VIEW ;
D FULL^VALM1
N DIR,DTOUT,DUOUT,DIROUT,DIROUT,Y
S DIR(0)="SO^N:NAME;T:TYPE"
S DIR("A")="Select View Type"
D ^DIR
I $D(DTOUT),$D(DUOUT),$D(DIROUT) Q
I Y="N" S MODE=0 D ENTRY
I Y="T" S MODE=1 D ENTRY
Q
;
XQORM ;
S XQORM("#")=$O(^ORD(101,"B","PXRM PATIENT LIST USER SELECT ENTRY",0))_U_"1:"_VALMCNT
S XQORM("A")="Select Item: "
Q
;
XSEL ;SELECT validation
N EPIEN,LEVEL,LISTIEN,LRIEN,NODE,SEL
S SEL=$P(XQORNOD(0),"=",2)
;Remove trailing ,
I $E(SEL,$L(SEL))="," S SEL=$E(SEL,1,$L(SEL)-1)
;Invalid selection
I SEL["," D Q
.W $C(7),!,"Only one item number allowed." H 2
.S VALMBCK="R"
I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("SEL",SEL))) D Q
.W $C(7),!,SEL_" is not a valid item number." H 2
.S VALMBCK="R"
;
;Get the patient list ien
S LISTIEN=^TMP("PXRMLPU",$J,"SEL",SEL)
;Get extract definition ien (if present)
S EPIEN=$P($G(^PXRMXP(810.5,LISTIEN,0)),U,5)
;Get list rule ien
S LRIEN=$P($G(^PXRMXP(810.5,LISTIEN,0)),U,6)
S NODE=$G(^PXRMXP(810.5,LISTIEN,0))
;
;Full screen mode
D FULL^VALM1
;
;Option to Install, Delete or Install History
N ACCESS,DELOK,DIR,OPTION,RIEN,X,Y
K DIROUT,DIRUT,DTOUT,DUOUT
S ACCESS=$$ACCESS(LISTIEN,NODE)
S DELOK=$$LDELOK^PXRMEUT(LISTIEN)
S DIR(0)="SBM"_U_"CO:Copy Patient List;"
S DIR(0)=DIR(0)_"COE:Copy to OE/RR Team;"
I DELOK S DIR(0)=DIR(0)_"DE:Delete Patient List;"
S DIR(0)=DIR(0)_"DCD:Display Creation Documentation;"
S DIR(0)=DIR(0)_"DSP:Display Patient List;"
S DIR("A")="Select Action: "
S DIR("B")="DSP"
S DIR("?")="Select from the codes displayed. For detailed help type ??"
S DIR("??")=U_"D HELP^PXRMLPU(1)"
D ^DIR K DIR
I $D(DIROUT) S DTOUT=1
I $D(DTOUT)!($D(DUOUT)) S VALMBCK="R" Q
S OPTION=Y
;
I $G(OPTION)="" G XSELE
;
;Copy patient list
I OPTION="CO" D COPY^PXRMRUL1(LISTIEN)
Q:$D(DUOUT)!$D(DTOUT)
;
;Copy to OE/RR Team
I OPTION="COE" D OERR^PXRMLPOE(LISTIEN)
Q:$D(DUOUT)!$D(DTOUT)
;
;Delete patient list
I OPTION="DE" D PDELETE
;
;Display creation documentation
I OPTION="DCD" D EN^PXRMLCD(LISTIEN)
;
;Display patient list
I OPTION="DSP" D START^PXRMLPP(LISTIEN)
;
XSELE ;
D CLEAN^VALM10
D BLDLIST,XQORM
S VALMBCK="R"
Q
PXRMLPU ; SLC/PKR/PJH - Reminder Patient List ;10/11/2007
+1 ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+2 ;
+3 ;Main entry point for PXRM PATIENT LIST
START(MODE) ;
+1 NEW PXRMDONE,VALMBCK,VALMSG,X,XMZ,MODE1
+2 SET X="IORESET"
+3 DO ENDR^%ZISS
+4 SET VALMCNT=0
+5 DO EN^VALM("PXRM PATIENT LIST USER")
+6 WRITE IORESET
+7 DO KILL^%ZISS
+8 QUIT
+9 ;
ACCESS(IEN,NODE) ;
+1 ;Holders of the PXRM MANAGER key have full access to all lists.
+2 ;DBIA #10076
+3 IF $DATA(^XUSEC("PXRM MANAGER",DUZ))
QUIT "F"
+4 NEW ACCESS,TYPE
+5 IF $GET(NODE)=""
SET NODE=$GET(^PXRMXP(810.5,IEN,0))
+6 SET TYPE=$PIECE(NODE,U,8)
+7 IF TYPE=""
QUIT "F"
+8 IF TYPE="PUB"
QUIT "F"
+9 IF $PIECE(NODE,U,7)=DUZ
QUIT "F"
+10 SET ACCESS="N"
+11 IF TYPE="PVT"
IF $DATA(^PXRMXP(810.5,IEN,40,"B",DUZ))
Begin DoDot:1
+12 NEW USIEN,STATUS
+13 SET USIEN=$ORDER(^PXRMXP(810.5,IEN,40,"B",DUZ,""))
+14 SET ACCESS=$SELECT(USIEN="":"N",1:$PIECE(^PXRMXP(810.5,IEN,40,USIEN,0),U,2))
End DoDot:1
+15 QUIT ACCESS
+16 ;
BLDLIST ;
+1 NEW PLIST
+2 KILL ^TMP("PXRMLPU",$JOB)
+3 KILL ^TMP("PXRMLPUH",$JOB)
+4 SET PLIST="PXRMLPU"
+5 DO LIST(MODE,PLIST)
+6 SET VALMCNT=+$GET(^TMP("PXRMLPU",$JOB,"VALMCNT"))
+7 QUIT
+8 ;
ENTRY ;Entry code
+1 ;MODE=0 ORDER BY NAME
+2 ;MODE=1 ORDER BY TYPE
+3 IF $GET(MODE)'>0
SET MODE=0
+4 DO BLDLIST
DO XQORM
+5 QUIT
+6 ;
EXIT ;Exit code
+1 KILL ^TMP("PXRMLPU",$JOB)
+2 KILL ^TMP("PXRMLPUH",$JOB)
+3 DO CLEAN^VALM10
+4 DO FULL^VALM1
+5 SET VALMBCK="R"
+6 QUIT
+7 ;
HDR ; Header code
+1 NEW NAME
+2 SET VALMHDR(1)="Available Patient Lists."
+3 QUIT
+4 ;
HELP(CALL) ;General help text routine
+1 NEW HTEXT
+2 IF CALL=1
Begin DoDot:1
+3 SET HTEXT(1)="Select CO to copy the patient list.\\"
+4 SET HTEXT(2)="Select COE to copy the patient list to an OE/RR Team.\\"
+5 SET HTEXT(3)="Select DE to delete the patient list.\\"
+6 SET HTEXT(4)="Select DCD to display creation documentation.\\"
+7 SET HTEXT(5)="Select DSP to display the patient list.\\"
End DoDot:1
+8 DO HELP^PXRMEUT(.HTEXT)
+9 QUIT
+10 ;
HLP ;Help code
+1 NEW ORU,ORUPRMT,SUB,XQORM
+2 SET SUB="PXRMLPUH"
+3 DO EN^VALM("PXRM PATIENT LIST HELP")
+4 QUIT
+5 ;
INIT ;Init
+1 SET VALMCNT=0
+2 QUIT
+3 ;
LIST(MODE,PLIST) ;Build a list of patient list entries.
+1 NEW ACCESS,COUNT,DATA,DATE,IND,FMTSTR,FNAME,OUTPUT,NAME,NL,NUM
+2 NEW STR,SUB,TYPE
+3 SET FMTSTR=$$LMFMTSTR^PXRMTEXT(.VALMDDF,"RLLRRC")
+4 ;MODE=0 build list in alphabetical order
+5 ;MODE=1 build list by type of list.
+6 KILL ^TMP($JOB,PLIST),^TMP(PLIST,$JOB)
+7 SET VALMCNT=0
SET NAME=""
SET NUM=0
SET TYPE=""
+8 FOR
SET NAME=$ORDER(^PXRMXP(810.5,"B",NAME))
IF NAME=""
QUIT
Begin DoDot:1
+9 SET IND=""
FOR
SET IND=$ORDER(^PXRMXP(810.5,"B",NAME,IND))
IF 'IND
QUIT
Begin DoDot:2
+10 SET DATA=$GET(^PXRMXP(810.5,IND,0))
+11 SET ACCESS=$$ACCESS(IND,DATA)
+12 IF ACCESS="N"
QUIT
+13 SET FNAME=$PIECE($GET(DATA),U)
SET DATE=$PIECE($GET(DATA),U,4)
+14 SET COUNT=+$PIECE($GET(^PXRMXP(810.5,IND,30,0)),U,4)
+15 SET TYPE=$PIECE(DATA,U,8)
+16 SET SUB=$SELECT(MODE=0:"NAME",1:TYPE)
+17 SET ^TMP($JOB,PLIST,SUB,FNAME)=IND_U_DATE_U_COUNT_U_TYPE_U_ACCESS
End DoDot:2
End DoDot:1
+18 IF '$DATA(^TMP($JOB,PLIST))
QUIT
+19 ;Loop through ARRAY to populate the output list
+20 ;sub is either the type of list or 'NAME'. If sort is
+21 ;by TYPE show PVT lists first.
+22 SET SUB=""
+23 FOR
SET SUB=$ORDER(^TMP($JOB,PLIST,SUB),-1)
IF SUB=""
QUIT
Begin DoDot:1
+24 SET FNAME=""
+25 FOR
SET FNAME=$ORDER(^TMP($JOB,PLIST,SUB,FNAME))
IF FNAME=""
QUIT
Begin DoDot:2
+26 SET DATA=^TMP($JOB,PLIST,SUB,FNAME)
SET NUM=NUM+1
+27 SET ^TMP("PXRMLPU",$JOB,"SEL",NUM)=$PIECE(DATA,U,1)
+28 SET DATE=$PIECE(DATA,U,2)
SET DATE=$$FMTE^XLFDT(DATE,2)
+29 SET $PIECE(DATA,U,2)=DATE
+30 SET STR=NUM_U_FNAME_U_$PIECE(DATA,U,2,5)
+31 DO COLFMT^PXRMTEXT(FMTSTR,STR," ",.NL,.OUTPUT)
+32 FOR IND=1:1:NL
Begin DoDot:3
+33 SET VALMCNT=VALMCNT+1
SET ^TMP(PLIST,$JOB,VALMCNT,0)=OUTPUT(IND)
+34 SET ^TMP("PXRMLPU",$JOB,"IDX",VALMCNT,NUM)=""
End DoDot:3
End DoDot:2
End DoDot:1
+35 SET ^TMP(PLIST,$JOB,"VALMCNT")=VALMCNT
+36 KILL ^TMP($JOB,PLIST)
+37 QUIT
+38 ;
PCOPY ;Patient list copy
+1 SET SUB="PXRMLPU"
+2 DO PCOPY1(SUB)
+3 DO BLDLIST
+4 SET VALMBCK="R"
+5 QUIT
+6 ;
PCOPY1(SUB) ;
+1 ;Full Screen
+2 WRITE IORESET
+3 NEW IND,LISTIEN,VALMY
+4 DO EN^VALM2(XQORNOD(0))
+5 ;If there is no list quit.
+6 IF '$DATA(VALMY)
QUIT
+7 SET IND=""
SET PXRMDONE=0
+8 FOR
SET IND=$ORDER(VALMY(IND))
IF (+IND=0)!(PXRMDONE)
QUIT
Begin DoDot:1
+9 ;Get the patient list ien.
+10 SET LISTIEN=^TMP(SUB,$JOB,"SEL",IND)
+11 DO COPY^PXRMRUL1(LISTIEN)
End DoDot:1
+12 QUIT
+13 ;
PDELETE ;Patient list delete
+1 ;Full Screen
+2 WRITE IORESET
+3 NEW DELOK,IND,LISTIEN,NODE,VALMY
+4 DO EN^VALM2(XQORNOD(0))
+5 ;If there is no list quit.
+6 IF '$DATA(VALMY)
QUIT
+7 SET IND=""
SET PXRMDONE=0
+8 FOR
SET IND=$ORDER(VALMY(IND))
IF (+IND=0)!(PXRMDONE)
QUIT
Begin DoDot:1
+9 ;Get the patient list ien.
+10 SET LISTIEN=^TMP("PXRMLPU",$JOB,"SEL",IND)
+11 SET NODE=$GET(^PXRMXP(810.5,LISTIEN,0))
+12 SET DELOK=$$LDELOK^PXRMEUT(LISTIEN)
+13 IF DELOK
DO DELETE^PXRMRUL1(LISTIEN)
QUIT
+14 IF '$TEST
Begin DoDot:2
+15 WRITE !,"In order to delete a list you must be the creator or a Reminder Manager!"
+16 SET PXRMDONE=1
HANG 2
End DoDot:2
QUIT
End DoDot:1
+17 DO BLDLIST
+18 SET VALMBCK="R"
+19 QUIT
+20 ;
PEXIT ;Protocol exit code
+1 SET VALMSG="+ Next Screen - Prev Screen ?? More Actions"
+2 ;Reset after page up/down etc
+3 DO XQORM
+4 QUIT
+5 ;
POERR ;Patient list copy to OERR Team (#101.21)
+1 ;Full Screen
+2 WRITE IORESET
+3 NEW ACCESS,IND,LISTIEN,NODE,USIEN,VALMY
+4 DO EN^VALM2(XQORNOD(0))
+5 ;If there is no list quit.
+6 IF '$DATA(VALMY)
QUIT
+7 SET IND=""
SET PXRMDONE=0
+8 FOR
SET IND=$ORDER(VALMY(IND))
IF (+IND=0)!(PXRMDONE)
QUIT
Begin DoDot:1
+9 ;Get the patient list ien.
+10 SET LISTIEN=^TMP("PXRMLPU",$JOB,"SEL",IND)
+11 SET NODE=$GET(^PXRMXP(810.5,LISTIEN,0))
+12 SET ACCESS=$$ACCESS^PXRMLPU(LISTIEN,NODE)
+13 IF ACCESS="F"
DO OERR^PXRMLPOE(LISTIEN)
+14 IF ACCESS="N"
Begin DoDot:2
+15 WRITE !,"The list cannot be copied; you must have full access to copy the list to an OE/RR team!"
+16 SET PXRMDONE=1
HANG 2
End DoDot:2
End DoDot:1
+17 SET VALMBCK="R"
+18 QUIT
+19 ;
PLIST ;Patient list inquiry.
+1 NEW CREAT,NAME,IND,LISTIEN,USIEN,VALMY,CREAT,NODE,TRUE
+2 DO EN^VALM2(XQORNOD(0))
+3 ;If there is no list quit.
+4 IF '$DATA(VALMY)
QUIT
+5 ;PXRMDONE is newed in PXRMLPU
+6 SET PXRMDONE=0
+7 SET IND=""
+8 FOR
SET IND=$ORDER(VALMY(IND))
IF (+IND=0)!(PXRMDONE)
QUIT
Begin DoDot:1
+9 SET LISTIEN=^TMP("PXRMLPU",$JOB,"SEL",IND)
+10 DO START^PXRMLPP(LISTIEN)
End DoDot:1
+11 DO BLDLIST
+12 SET VALMBCK="R"
+13 QUIT
+14 ;
VIEW ;
+1 DO FULL^VALM1
+2 NEW DIR,DTOUT,DUOUT,DIROUT,DIROUT,Y
+3 SET DIR(0)="SO^N:NAME;T:TYPE"
+4 SET DIR("A")="Select View Type"
+5 DO ^DIR
+6 IF $DATA(DTOUT)
IF $DATA(DUOUT)
IF $DATA(DIROUT)
QUIT
+7 IF Y="N"
SET MODE=0
DO ENTRY
+8 IF Y="T"
SET MODE=1
DO ENTRY
+9 QUIT
+10 ;
XQORM ;
+1 SET XQORM("#")=$ORDER(^ORD(101,"B","PXRM PATIENT LIST USER SELECT ENTRY",0))_U_"1:"_VALMCNT
+2 SET XQORM("A")="Select Item: "
+3 QUIT
+4 ;
XSEL ;SELECT validation
+1 NEW EPIEN,LEVEL,LISTIEN,LRIEN,NODE,SEL
+2 SET SEL=$PIECE(XQORNOD(0),"=",2)
+3 ;Remove trailing ,
+4 IF $EXTRACT(SEL,$LENGTH(SEL))=","
SET SEL=$EXTRACT(SEL,1,$LENGTH(SEL)-1)
+5 ;Invalid selection
+6 IF SEL[","
Begin DoDot:1
+7 WRITE $CHAR(7),!,"Only one item number allowed."
HANG 2
+8 SET VALMBCK="R"
End DoDot:1
QUIT
+9 IF ('SEL)!(SEL>VALMCNT)!('$DATA(@VALMAR@("SEL",SEL)))
Begin DoDot:1
+10 WRITE $CHAR(7),!,SEL_" is not a valid item number."
HANG 2
+11 SET VALMBCK="R"
End DoDot:1
QUIT
+12 ;
+13 ;Get the patient list ien
+14 SET LISTIEN=^TMP("PXRMLPU",$JOB,"SEL",SEL)
+15 ;Get extract definition ien (if present)
+16 SET EPIEN=$PIECE($GET(^PXRMXP(810.5,LISTIEN,0)),U,5)
+17 ;Get list rule ien
+18 SET LRIEN=$PIECE($GET(^PXRMXP(810.5,LISTIEN,0)),U,6)
+19 SET NODE=$GET(^PXRMXP(810.5,LISTIEN,0))
+20 ;
+21 ;Full screen mode
+22 DO FULL^VALM1
+23 ;
+24 ;Option to Install, Delete or Install History
+25 NEW ACCESS,DELOK,DIR,OPTION,RIEN,X,Y
+26 KILL DIROUT,DIRUT,DTOUT,DUOUT
+27 SET ACCESS=$$ACCESS(LISTIEN,NODE)
+28 SET DELOK=$$LDELOK^PXRMEUT(LISTIEN)
+29 SET DIR(0)="SBM"_U_"CO:Copy Patient List;"
+30 SET DIR(0)=DIR(0)_"COE:Copy to OE/RR Team;"
+31 IF DELOK
SET DIR(0)=DIR(0)_"DE:Delete Patient List;"
+32 SET DIR(0)=DIR(0)_"DCD:Display Creation Documentation;"
+33 SET DIR(0)=DIR(0)_"DSP:Display Patient List;"
+34 SET DIR("A")="Select Action: "
+35 SET DIR("B")="DSP"
+36 SET DIR("?")="Select from the codes displayed. For detailed help type ??"
+37 SET DIR("??")=U_"D HELP^PXRMLPU(1)"
+38 DO ^DIR
KILL DIR
+39 IF $DATA(DIROUT)
SET DTOUT=1
+40 IF $DATA(DTOUT)!($DATA(DUOUT))
SET VALMBCK="R"
QUIT
+41 SET OPTION=Y
+42 ;
+43 IF $GET(OPTION)=""
GOTO XSELE
+44 ;
+45 ;Copy patient list
+46 IF OPTION="CO"
DO COPY^PXRMRUL1(LISTIEN)
+47 IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+48 ;
+49 ;Copy to OE/RR Team
+50 IF OPTION="COE"
DO OERR^PXRMLPOE(LISTIEN)
+51 IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+52 ;
+53 ;Delete patient list
+54 IF OPTION="DE"
DO PDELETE
+55 ;
+56 ;Display creation documentation
+57 IF OPTION="DCD"
DO EN^PXRMLCD(LISTIEN)
+58 ;
+59 ;Display patient list
+60 IF OPTION="DSP"
DO START^PXRMLPP(LISTIEN)
+61 ;
XSELE ;
+1 DO CLEAN^VALM10
+2 DO BLDLIST
DO XQORM
+3 SET VALMBCK="R"
+4 QUIT
