PXRMLPAU ; SLC/AGP - Reminder Patient List ;09/06/2007
;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
;
;Main entry point for PXRM PATIENT LIST
START(IEN) ;
N PXRMDONE,VALMBCK,VALMSG,X,XMZ
S X="IORESET"
S VALMCNT=0
D EN^VALM("PXRM PATIENT LIST AUTH USERS")
W IORESET
Q
;
BLDLIST ;
N PLIST,PIEN
K ^TMP("PXRMLPAU",$J)
K ^TMP("PXRMLPAH",$J)
D LIST(.PLIST,.PIEN)
I $D(PLIST)=0 G EXIT
M ^TMP("PXRMLPAU",$J)=PLIST
S VALMCNT=PLIST("VALMCNT")
F IND=1:1:VALMCNT D
.S ^TMP("PXRMLPAU",$J,"IDX",IND,IND)=PIEN(IND)
Q
;
LIST(RLIST,PIEN) ;Build a list of patient list users.
N ACCESS,ARRAY,COUNT,DATE,DFN,IND,SIEN,FNAME,NAME,NODE,LEVEL
;Build the list in alphabetical order.
S VALMCNT=0
S DFN=""
F S DFN=$O(^PXRMXP(810.5,IEN,40,"B",DFN)) Q:DFN="" D
.S IND=""
.F S IND=$O(^PXRMXP(810.5,IEN,40,"B",DFN,IND)) Q:'IND D
..S ACCESS=$P($G(^PXRMXP(810.5,IEN,40,IND,0)),U,2)
..S FNAME=$$GET1^DIQ(200,DFN,.01) Q:$G(FNAME)=""
..S ARRAY(FNAME)=$G(IND)_U_$G(ACCESS)
I $D(ARRAY)=0 Q
S NAME="" F S NAME=$O(ARRAY(NAME)) Q:NAME="" D
.S VALMCNT=VALMCNT+1
.S RLIST(VALMCNT,0)=$$FRE(VALMCNT,NAME,$P($G(ARRAY(NAME)),U,2))
.S PIEN(VALMCNT)=$P($G(ARRAY(NAME)),U)
S RLIST("VALMCNT")=VALMCNT
Q
;
FRE(NUMBER,NAME,ACCESS) ;Format entry number, name, source,
;and date packed.
N TEMP,TNAME,TSOURCE
S TEMP=$$RJ^XLFSTR(NUMBER,5," ")
S TNAME=$E(NAME,1,45)
S TEMP=TEMP_" "_TNAME
S TEMP=$$LJ^XLFSTR(TEMP,40," ")_ACCESS
Q TEMP
;
ENTRY ;Entry code
D BLDLIST,XQORM
Q
;
EXIT ;Exit code
K ^TMP("PXRMLPAU",$J)
K ^TMP("PXRMLPAH",$J)
D CLEAN^VALM10
D FULL^VALM1
Q
;
HDR ; Header code
S VALMHDR(1)="Available Patient Lists."
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
Q
;
HLP ;Help code
N ORU,ORUPRMT,SUB,XQORM
S SUB="PXRMLPAH"
D EN^VALM("PXRM PATIENT LIST HELP")
Q
;
INIT ;Init
S VALMCNT=0
Q
;
PEXIT ;PXRM MENU protocol exit code
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
;Reset after page up/down etc
D XQORM
Q
;
ADD ;add a user
N CREAT,CNT,DIC,DIE,FDA,MSG,USER,Y
S CREAT=$P($G(^PXRMXP(810.5,IEN,0)),U,7)
I $G(CREAT)'=DUZ D G ADDE
. W !,"Only the creator of this list can add an user." H 2
D FULL^VALM1
S DIC="^VA(200,"
S DIC(0)="QAEB"
S DIC("A")="Select Users: "
D ^DIC
I Y=-1 Q
S USER=+Y
K Y
K DIROUT,DIRUT,DTOUT,DUOUT
S DIR(0)="S^F:Full Control;V:View Only"
S DIR("A")="Select level of control: "
S DIR("B")="V"
S DIR("?")="Enter F or V. For detailed help type ??"
W !
D ^DIR K DIR
I $D(DIROUT) S DTOUT=1
I $D(DTOUT)!($D(DUOUT)) Q
I $G(Y)="" W !,"A level of control must be entered." H 2 Q
S YESNO=$E(Y(0))
S FDA(810.54,"+2,"_IEN_",",.01)=USER
S FDA(810.54,"+2,"_IEN_",",1)=Y
D UPDATE^DIE("","FDA","","MSG")
I $D(MSG)>0 D AWRITE^PXRMUTIL("MSG") H 2
ADDE ;
D BLDLIST
S VALMBCK="R"
Q
;
XQORM ;
S XQORM("#")=$O(^ORD(101,"B","PXRM PATIENT LIST AUTH USER SELECT",0))_U_"1:"_VALMCNT
S XQORM("A")="Select Item: "
Q
;
XSEL ;PXRM SELECT COMPONENT validation
N EPIEN,LISTIEN,LRIEN,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@("IDX",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("PXRMLPAU",$J,"IDX",SEL,SEL)
;Full screen mode
D FULL^VALM1
D PDELETE
;
;Option to Install, Delete or Install History
;
S VALMBCK="R"
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 DSP to display the patient list.\\"
D HELP^PXRMEUT(.HTEXT)
Q
;
PDELETE ;Patient list delete
;
;Full Screen
W IORESET
;
N CREAT,IND,LISTIEN,NODE
I DUZ'=$P($G(^PXRMXP(810.5,IEN,0)),U,7) D G PDELEX
.W !,"Only the creator of this list can delete it." H 2
D EN^VALM2(XQORNOD(0))
;If there is no list quit.
I '$D(VALMY) D BLDLIST S VALMBCK="R" Q
S IND="",PXRMDONE=0
F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D
.;Get the patient list ien.
.S LISTIEN=^TMP("PXRMLPAU",$J,"IDX",IND,IND)
.S DA(1)=IEN,DA=LISTIEN,DIK="^PXRMXP(810.5,"_DA(1)_",40," D ^DIK
.W !,"Patient list deleted"
;
PDELEX ;
D BLDLIST
;
S VALMBCK="R"
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMLPAU 4571 printed Dec 13, 2024@01:46:32 Page 2
PXRMLPAU ; SLC/AGP - Reminder Patient List ;09/06/2007
+1 ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+2 ;
+3 ;Main entry point for PXRM PATIENT LIST
START(IEN) ;
+1 NEW PXRMDONE,VALMBCK,VALMSG,X,XMZ
+2 SET X="IORESET"
+3 SET VALMCNT=0
+4 DO EN^VALM("PXRM PATIENT LIST AUTH USERS")
+5 WRITE IORESET
+6 QUIT
+7 ;
BLDLIST ;
+1 NEW PLIST,PIEN
+2 KILL ^TMP("PXRMLPAU",$JOB)
+3 KILL ^TMP("PXRMLPAH",$JOB)
+4 DO LIST(.PLIST,.PIEN)
+5 IF $DATA(PLIST)=0
GOTO EXIT
+6 MERGE ^TMP("PXRMLPAU",$JOB)=PLIST
+7 SET VALMCNT=PLIST("VALMCNT")
+8 FOR IND=1:1:VALMCNT
Begin DoDot:1
+9 SET ^TMP("PXRMLPAU",$JOB,"IDX",IND,IND)=PIEN(IND)
End DoDot:1
+10 QUIT
+11 ;
LIST(RLIST,PIEN) ;Build a list of patient list users.
+1 NEW ACCESS,ARRAY,COUNT,DATE,DFN,IND,SIEN,FNAME,NAME,NODE,LEVEL
+2 ;Build the list in alphabetical order.
+3 SET VALMCNT=0
+4 SET DFN=""
+5 FOR
SET DFN=$ORDER(^PXRMXP(810.5,IEN,40,"B",DFN))
if DFN=""
QUIT
Begin DoDot:1
+6 SET IND=""
+7 FOR
SET IND=$ORDER(^PXRMXP(810.5,IEN,40,"B",DFN,IND))
if 'IND
QUIT
Begin DoDot:2
+8 SET ACCESS=$PIECE($GET(^PXRMXP(810.5,IEN,40,IND,0)),U,2)
+9 SET FNAME=$$GET1^DIQ(200,DFN,.01)
if $GET(FNAME)=""
QUIT
+10 SET ARRAY(FNAME)=$GET(IND)_U_$GET(ACCESS)
End DoDot:2
End DoDot:1
+11 IF $DATA(ARRAY)=0
QUIT
+12 SET NAME=""
FOR
SET NAME=$ORDER(ARRAY(NAME))
if NAME=""
QUIT
Begin DoDot:1
+13 SET VALMCNT=VALMCNT+1
+14 SET RLIST(VALMCNT,0)=$$FRE(VALMCNT,NAME,$PIECE($GET(ARRAY(NAME)),U,2))
+15 SET PIEN(VALMCNT)=$PIECE($GET(ARRAY(NAME)),U)
End DoDot:1
+16 SET RLIST("VALMCNT")=VALMCNT
+17 QUIT
+18 ;
FRE(NUMBER,NAME,ACCESS) ;Format entry number, name, source,
+1 ;and date packed.
+2 NEW TEMP,TNAME,TSOURCE
+3 SET TEMP=$$RJ^XLFSTR(NUMBER,5," ")
+4 SET TNAME=$EXTRACT(NAME,1,45)
+5 SET TEMP=TEMP_" "_TNAME
+6 SET TEMP=$$LJ^XLFSTR(TEMP,40," ")_ACCESS
+7 QUIT TEMP
+8 ;
ENTRY ;Entry code
+1 DO BLDLIST
DO XQORM
+2 QUIT
+3 ;
EXIT ;Exit code
+1 KILL ^TMP("PXRMLPAU",$JOB)
+2 KILL ^TMP("PXRMLPAH",$JOB)
+3 DO CLEAN^VALM10
+4 DO FULL^VALM1
+5 QUIT
+6 ;
HDR ; Header code
+1 SET VALMHDR(1)="Available Patient Lists."
+2 SET VALMSG="+ Next Screen - Prev Screen ?? More Actions"
+3 QUIT
+4 ;
HLP ;Help code
+1 NEW ORU,ORUPRMT,SUB,XQORM
+2 SET SUB="PXRMLPAH"
+3 DO EN^VALM("PXRM PATIENT LIST HELP")
+4 QUIT
+5 ;
INIT ;Init
+1 SET VALMCNT=0
+2 QUIT
+3 ;
PEXIT ;PXRM MENU 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 ;
ADD ;add a user
+1 NEW CREAT,CNT,DIC,DIE,FDA,MSG,USER,Y
+2 SET CREAT=$PIECE($GET(^PXRMXP(810.5,IEN,0)),U,7)
+3 IF $GET(CREAT)'=DUZ
Begin DoDot:1
+4 WRITE !,"Only the creator of this list can add an user."
HANG 2
End DoDot:1
GOTO ADDE
+5 DO FULL^VALM1
+6 SET DIC="^VA(200,"
+7 SET DIC(0)="QAEB"
+8 SET DIC("A")="Select Users: "
+9 DO ^DIC
+10 IF Y=-1
QUIT
+11 SET USER=+Y
+12 KILL Y
+13 KILL DIROUT,DIRUT,DTOUT,DUOUT
+14 SET DIR(0)="S^F:Full Control;V:View Only"
+15 SET DIR("A")="Select level of control: "
+16 SET DIR("B")="V"
+17 SET DIR("?")="Enter F or V. For detailed help type ??"
+18 WRITE !
+19 DO ^DIR
KILL DIR
+20 IF $DATA(DIROUT)
SET DTOUT=1
+21 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+22 IF $GET(Y)=""
WRITE !,"A level of control must be entered."
HANG 2
QUIT
+23 SET YESNO=$EXTRACT(Y(0))
+24 SET FDA(810.54,"+2,"_IEN_",",.01)=USER
+25 SET FDA(810.54,"+2,"_IEN_",",1)=Y
+26 DO UPDATE^DIE("","FDA","","MSG")
+27 IF $DATA(MSG)>0
DO AWRITE^PXRMUTIL("MSG")
HANG 2
ADDE ;
+1 DO BLDLIST
+2 SET VALMBCK="R"
+3 QUIT
+4 ;
XQORM ;
+1 SET XQORM("#")=$ORDER(^ORD(101,"B","PXRM PATIENT LIST AUTH USER SELECT",0))_U_"1:"_VALMCNT
+2 SET XQORM("A")="Select Item: "
+3 QUIT
+4 ;
XSEL ;PXRM SELECT COMPONENT validation
+1 NEW EPIEN,LISTIEN,LRIEN,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@("IDX",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 ;Get the patient list ien
+13 SET LISTIEN=^TMP("PXRMLPAU",$JOB,"IDX",SEL,SEL)
+14 ;Full screen mode
+15 DO FULL^VALM1
+16 DO PDELETE
+17 ;
+18 ;Option to Install, Delete or Install History
+19 ;
+20 SET VALMBCK="R"
+21 QUIT
+22 ;
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 DSP to display the patient list.\\"
End DoDot:1
+7 DO HELP^PXRMEUT(.HTEXT)
+8 QUIT
+9 ;
PDELETE ;Patient list delete
+1 ;
+2 ;Full Screen
+3 WRITE IORESET
+4 ;
+5 NEW CREAT,IND,LISTIEN,NODE
+6 IF DUZ'=$PIECE($GET(^PXRMXP(810.5,IEN,0)),U,7)
Begin DoDot:1
+7 WRITE !,"Only the creator of this list can delete it."
HANG 2
End DoDot:1
GOTO PDELEX
+8 DO EN^VALM2(XQORNOD(0))
+9 ;If there is no list quit.
+10 IF '$DATA(VALMY)
DO BLDLIST
SET VALMBCK="R"
QUIT
+11 SET IND=""
SET PXRMDONE=0
+12 FOR
SET IND=$ORDER(VALMY(IND))
if (+IND=0)!(PXRMDONE)
QUIT
Begin DoDot:1
+13 ;Get the patient list ien.
+14 SET LISTIEN=^TMP("PXRMLPAU",$JOB,"IDX",IND,IND)
+15 SET DA(1)=IEN
SET DA=LISTIEN
SET DIK="^PXRMXP(810.5,"_DA(1)_",40,"
DO ^DIK
+16 WRITE !,"Patient list deleted"
End DoDot:1
+17 ;
PDELEX ;
+1 DO BLDLIST
+2 ;
+3 SET VALMBCK="R"
+4 QUIT
+5 ;
