ORLP1 ; SLC/DCM,CLA - Patient Lists, Store ; 1/19/11 10:12am
;;3.0;ORDER ENTRY/RESULTS REPORTING;**11,63,90,98,273**;Dec 17, 1997;Build 17
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;DBIA reference section
;2160 - ^XUTL("OR"
;10006 - DIC
;10009 - YN^DICN
;10018 - DIE
;10013 - DIK
;10026 - DIR
;2957 - CLNLIST^GMRCTU
;2263 - XPAR
;
STOR ;called by ORLP0 - Store lists
N %,DA,DIC,DIK,DIR,DLAYGO,DR,ORLIST,ORLN,I,J,X,Y
W !!,"Store list for future reference"
S %=1 D YN^DICN Q:%=-1
I %=0 W !,"You may store the newly compiled list. Answer YES or NO." G STOR
Q:%=2
;
GETNAME ; Call DIR to get user entry for new list name:
N ORTNAM
S ORTNAM=""
N ORNEWL ; Flag used to indicate a new list (v. existing list).
S ORNEWL=1 ; Begin w/assumption of a new list name.
F D Q:$D(X)
.S DIR(0)="FAO^3:30",DIR("A")="Enter a name for this list: "
.D ^DIR
.I '$D(X)!($D(DIRUT)) K DIRUT W " List not permanently stored." Q
.S (ORLN,ORTNAM)=X
.S X=$G(X),DIC="^OR(100.21,"
.D ^DIC
I '$D(X)!(X="") Q
I +Y>0 S ORLIST=+Y,ORLN=$P(Y,U,2) K DIC S Y=ORLIST S ORNEWL=0 ; List name already exists.
;
OVRWR ;
N ORABORT ; Flag for aborting process.
N ERROR
S ORABORT=0
;
; Check for problems with name entry:
I 'ORNEWL D
.I $$NAMCH(+ORLIST) S ORABORT=1
I ORABORT G GETNAME
;
; Ask - overwrite if an existing team by that name already?:
I 'ORNEWL D Q:$G(ERROR)
.I $O(^OR(100.21,+Y,10,0)) D Q:%'=1 ; Any patients on list yet?
..F D Q:%
...W !,ORLN_" already has patients. Do you want to overwrite it"
...S %=2 D YN^DICN
...I %=2!(%=-1) W !,"List ",ORLN," unchanged.",! S ORABORT=1 Q
...I '% W !,"Answer YES or NO, if you answer YES the list "_ORLN_" will be cleared,",!,"and this temporary list will overwrite it.",! Q
.I ORABORT Q
.L +^OR(100.21,+ORLIST):$G(DILOCKTM,3) I '$T W !,"Another user is editing this entry." S ERROR=1 Q
.I '$D(^OR(100.21,ORLIST,10,0))#2 S ^(0)="^100.2101AV^"
.I '$D(^OR(100.21,ORLIST,1,0))#2 S ^(0)="^100.212PA^"
.S I=0 F S I=$O(^OR(100.21,ORLIST,10,I)) Q:'I S DA=+I,DA(1)=+ORLIST,DIK="^OR(100.21,"_ORLIST_",10," D ^DIK
.L -^OR(100.21,+ORLIST)
I ORABORT G GETNAME
;
; If a new list name, write new team into OE/RR LIST file:
I ORNEWL D
.S DIC="^OR(100.21,",DLAYGO=100.21,DIC(0)="LEFQZ"
.D ^DIC
.I (Y<0!'$D(X)) S ORABORT=1 Q ; User aborted or there was a problem.
.S ORLIST=+Y
I ORABORT K DIC Q
;
; Assure other required entries if necessary:
I ORNEWL D
.I $P($G(^OR(100.21,+ORLIST,1,0)),U,2)'="P" D
..S DIE="^OR(100.21,",DA=ORLIST,DR="1///^S X=""P"""
..D ^DIE
..K DIE,DA
.I '$D(^OR(100.21,+ORLIST,1,DUZ)) S DA(1)=ORLIST,DIC="^OR(100.21,"_DA(1)_",1,",DIC(0)="LX",X="`"_DUZ D ^DIC K DIC
;
; Add selected patients to list (if any):
L +^OR(100.21,+ORLIST):$G(DILOCKTM,3) I '$T W !,"Another user is editing this entry." Q
S ORI=0
F S ORI=$O(^XUTL("OR",$J,"ORLP",ORI)) Q:ORI<1 I $D(^(ORI,0)) S X=^(0),X="PT.`"_+$P(X,"^",3),DA(1)=ORLIST,DIC="^OR(100.21,"_ORLIST_",10,",DIC(0)="LX" D ^DIC
K DIC,ORI
L -^OR(100.21,ORLIST)
W !!,"List has been stored."
Q
;
MERG ;called by option ORLP MERG - merge patient lists
D CLEAR^ORLP ;clear XUTL for merge
D ASK^ORLP0(.X)
I (X<0)!(X>1) Q
S:'$D(ORCNT) ORCNT=0
W @IOF,!,"Merging patients from two or more Personal and/or Team patient lists.",!
S DIC="^OR(100.21,",DIC(0)="AEQM",DIC("S")="I ""PT""[$E($P(^(0),U,2))"
F ORK=1:1 S ORCT=0,DIC("A")="Select LIST "_ORK_": " D P1^ORLP0 Q:ORY<1 I ORCNT>0 W !!,ORCT_" Patients added, "_ORCNT_" total"
Q:$D(DTOUT)!($D(DUOUT))
I 'ORCNT W !!,"List empty.",! D END^ORLP0 Q
D PR2^ORLA1(OROPREF)
W !!,"LIST PATIENTS MERGED"
D LIST^ORLP0
D STOR,END^ORLP0
D BUILD^ORLA1 ;load XUTL with user's primary list
K DIC,ORCEND,ORCLIN,ORCNT,ORCOLW,ORCSTRT,ORCT,ORDEF,ORK,ORPRIM,ORPROV,ORSPEC,ORTITLE,ORUPNM,ORUSSN,ORWARD,Y
Q
;
DEL ;called by option ORLP DELETE - delete a list
I '$D(ORLST) S DIC="^OR(100.21,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,2)'=""P""",DIC("A")="Select Team PATIENT LIST to delete: "
I $D(ORLST) S DIC="^OR(100.21,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,2)=""P""&($D(^OR(100.21,""C"",DUZ,+Y)))",DIC("A")="Select Personal PATIENT LIST to delete: "
D ^DIC
K DIC
I Y<1 Q
S ORPTEAM=Y
;
D2 ;
S %=""
I $$GET^XPAR("USR.`"_DUZ,"ORLP DEFAULT TEAM",1,"I")=+ORPTEAM W !!,"This is your primary patient list, are you sure you want to remove it" S %=2 D YN^DICN
I %=0 W !,"Answer YES if you really want to remove this list." G D2
I %'="" Q:%'=1
W !!,"WARNING - Deleting a patient list will disable access by providers who use the",!,"list as their preferred patient list."
;
D1 ;
L +^OR(100.21,+ORPTEAM):$G(DILOCKTM,3) I '$T W !,"Another user is editing this entry." Q
W !,"Are you ready to delete list ",$P(ORPTEAM,"^",2)
S %=2 D YN^DICN
I %=0 W !,"Enter YES to delete the list, NO to quit." G D1
Q:%'=1
W !,"Processing........"
;L +^OR(100.21,+ORPTEAM)
S DA=+ORPTEAM,DIK="^OR(100.21,"
D ^DIK
K DA,DIC,DIK
;
; Next 2 lines added by PKS, 2/8/2000:
W !,"Searching for/removing Consults pointers to deleted team..."
D CLNLIST^GMRCTU(+ORPTEAM,0) ; Dump pointers to team in file 123.5.
;
W !,"List deletion completed.",!
L -^OR(100.21,+ORPTEAM)
K ORPTEAM,ORLPDUZ,Y,XX,^TMP("ORLP",$J,"TLIST") ;KILL temporary list
G DEL
Q
;
CLEAR(X) ;called by option ORLP CLEAR - clear active list
I '$D(^XUTL("OR",$J,"ORLP")) W !!,"No list currently defined" S X=1 Q
F D Q:X
. W !!,"Are you sure you want to clear the current pt selection list"
. S %=2 D YN^DICN
. I %=-1 S X=% Q
. I %=0 W !!,"YES will clear the current pt selection list and leave you with a blank slate to work from." S X=0 Q
. I %=1 K ^XUTL("OR",$J,"ORLP"),^("ORV"),^("ORU"),^("ORW") S:$D(ORCNT) ORCNT=0 W !!,"List cleared" S X=% Q
. W !!,"Nothing done."
. S X=2
Q
;
NAMCH(ORTEAM) ; Check for name duplication, proper team type.
;
; Variables used:
;
; ORTEAM = IEN of team in Team List file (^OR100.21).
;
; Check for name duplication and not a "Personal" type team:
I $P($G(^OR(100.21,ORTEAM,0)),U,2)'="P" D Q 1
.W !,ORTNAM," name already used - can't overwrite.",!
.K X,Y,ORLIST,ORLN
;
; Check for "Personal" type but not current user's team:
; ("CREATOR" field was added later, so not used here.)
; Is this user's DUZ in "USER" multiple?
I '$D(^OR(100.21,"C",DUZ,ORTEAM)) D Q 1
.W !,ORTNAM," name exists, you are not a user - can't overwrite.",!
.K X,Y,ORLIST,ORLN
;
Q 0
;
OWNER ; Get input from CAC for list user/owner.
;
; Variables used herein:
;
; DIR,X,Y = FM call variables.
; ORYY = NEW'd in calling routine (ORLP).
; OROWNER = NEW'd in calling routine (ORLP).
;
N DIR,X,Y
;
; Assign variables and get input from CAC for user/owner of list:
S OROWNER="" ; Default.
S DIR(0)="PAO^200,:AEMNQ"
S DIR("A")=" Enter owner of this Personal type list: "
S DIR("S")="I $D(X),$D(^VA(200,""AK.PROVIDER"",$P(^(0),U))),$$ACTIVE^XUSER(+Y)"
S DIR("?")="Only owner you specify can edit list after creation."
D ^DIR
S OROWNER=Y
K DIR,X,Y ; Clean up.
I OROWNER<1 S OROWNER="" Q ; No acceptable entry.
S OROWNER=+OROWNER ; Selected user's DUZ.
S $P(^OR(100.21,+ORYY,0),U,5)=OROWNER ; Assign CREATOR field.
;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORLP1 7421 printed Sep 23, 2025@20:07:40 Page 2
ORLP1 ; SLC/DCM,CLA - Patient Lists, Store ; 1/19/11 10:12am
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**11,63,90,98,273**;Dec 17, 1997;Build 17
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;DBIA reference section
+5 ;2160 - ^XUTL("OR"
+6 ;10006 - DIC
+7 ;10009 - YN^DICN
+8 ;10018 - DIE
+9 ;10013 - DIK
+10 ;10026 - DIR
+11 ;2957 - CLNLIST^GMRCTU
+12 ;2263 - XPAR
+13 ;
STOR ;called by ORLP0 - Store lists
+1 NEW %,DA,DIC,DIK,DIR,DLAYGO,DR,ORLIST,ORLN,I,J,X,Y
+2 WRITE !!,"Store list for future reference"
+3 SET %=1
DO YN^DICN
if %=-1
QUIT
+4 IF %=0
WRITE !,"You may store the newly compiled list. Answer YES or NO."
GOTO STOR
+5 if %=2
QUIT
+6 ;
GETNAME ; Call DIR to get user entry for new list name:
+1 NEW ORTNAM
+2 SET ORTNAM=""
+3 ; Flag used to indicate a new list (v. existing list).
NEW ORNEWL
+4 ; Begin w/assumption of a new list name.
SET ORNEWL=1
+5 FOR
Begin DoDot:1
+6 SET DIR(0)="FAO^3:30"
SET DIR("A")="Enter a name for this list: "
+7 DO ^DIR
+8 IF '$DATA(X)!($DATA(DIRUT))
KILL DIRUT
WRITE " List not permanently stored."
QUIT
+9 SET (ORLN,ORTNAM)=X
+10 SET X=$GET(X)
SET DIC="^OR(100.21,"
+11 DO ^DIC
End DoDot:1
if $DATA(X)
QUIT
+12 IF '$DATA(X)!(X="")
QUIT
+13 ; List name already exists.
IF +Y>0
SET ORLIST=+Y
SET ORLN=$PIECE(Y,U,2)
KILL DIC
SET Y=ORLIST
SET ORNEWL=0
+14 ;
OVRWR ;
+1 ; Flag for aborting process.
NEW ORABORT
+2 NEW ERROR
+3 SET ORABORT=0
+4 ;
+5 ; Check for problems with name entry:
+6 IF 'ORNEWL
Begin DoDot:1
+7 IF $$NAMCH(+ORLIST)
SET ORABORT=1
End DoDot:1
+8 IF ORABORT
GOTO GETNAME
+9 ;
+10 ; Ask - overwrite if an existing team by that name already?:
+11 IF 'ORNEWL
Begin DoDot:1
+12 ; Any patients on list yet?
IF $ORDER(^OR(100.21,+Y,10,0))
Begin DoDot:2
+13 FOR
Begin DoDot:3
+14 WRITE !,ORLN_" already has patients. Do you want to overwrite it"
+15 SET %=2
DO YN^DICN
+16 IF %=2!(%=-1)
WRITE !,"List ",ORLN," unchanged.",!
SET ORABORT=1
QUIT
+17 IF '%
WRITE !,"Answer YES or NO, if you answer YES the list "_ORLN_" will be cleared,",!,"and this temporary list will overwrite it.",!
QUIT
End DoDot:3
if %
QUIT
End DoDot:2
if %'=1
QUIT
+18 IF ORABORT
QUIT
+19 LOCK +^OR(100.21,+ORLIST):$GET(DILOCKTM,3)
IF '$TEST
WRITE !,"Another user is editing this entry."
SET ERROR=1
QUIT
+20 IF '$DATA(^OR(100.21,ORLIST,10,0))#2
SET ^(0)="^100.2101AV^"
+21 IF '$DATA(^OR(100.21,ORLIST,1,0))#2
SET ^(0)="^100.212PA^"
+22 SET I=0
FOR
SET I=$ORDER(^OR(100.21,ORLIST,10,I))
if 'I
QUIT
SET DA=+I
SET DA(1)=+ORLIST
SET DIK="^OR(100.21,"_ORLIST_",10,"
DO ^DIK
+23 LOCK -^OR(100.21,+ORLIST)
End DoDot:1
if $GET(ERROR)
QUIT
+24 IF ORABORT
GOTO GETNAME
+25 ;
+26 ; If a new list name, write new team into OE/RR LIST file:
+27 IF ORNEWL
Begin DoDot:1
+28 SET DIC="^OR(100.21,"
SET DLAYGO=100.21
SET DIC(0)="LEFQZ"
+29 DO ^DIC
+30 ; User aborted or there was a problem.
IF (Y<0!'$DATA(X))
SET ORABORT=1
QUIT
+31 SET ORLIST=+Y
End DoDot:1
+32 IF ORABORT
KILL DIC
QUIT
+33 ;
+34 ; Assure other required entries if necessary:
+35 IF ORNEWL
Begin DoDot:1
+36 IF $PIECE($GET(^OR(100.21,+ORLIST,1,0)),U,2)'="P"
Begin DoDot:2
+37 SET DIE="^OR(100.21,"
SET DA=ORLIST
SET DR="1///^S X=""P"""
+38 DO ^DIE
+39 KILL DIE,DA
End DoDot:2
+40 IF '$DATA(^OR(100.21,+ORLIST,1,DUZ))
SET DA(1)=ORLIST
SET DIC="^OR(100.21,"_DA(1)_",1,"
SET DIC(0)="LX"
SET X="`"_DUZ
DO ^DIC
KILL DIC
End DoDot:1
+41 ;
+42 ; Add selected patients to list (if any):
+43 LOCK +^OR(100.21,+ORLIST):$GET(DILOCKTM,3)
IF '$TEST
WRITE !,"Another user is editing this entry."
QUIT
+44 SET ORI=0
+45 FOR
SET ORI=$ORDER(^XUTL("OR",$JOB,"ORLP",ORI))
if ORI<1
QUIT
IF $DATA(^(ORI,0))
SET X=^(0)
SET X="PT.`"_+$PIECE(X,"^",3)
SET DA(1)=ORLIST
SET DIC="^OR(100.21,"_ORLIST_",10,"
SET DIC(0)="LX"
DO ^DIC
+46 KILL DIC,ORI
+47 LOCK -^OR(100.21,ORLIST)
+48 WRITE !!,"List has been stored."
+49 QUIT
+50 ;
MERG ;called by option ORLP MERG - merge patient lists
+1 ;clear XUTL for merge
DO CLEAR^ORLP
+2 DO ASK^ORLP0(.X)
+3 IF (X<0)!(X>1)
QUIT
+4 if '$DATA(ORCNT)
SET ORCNT=0
+5 WRITE @IOF,!,"Merging patients from two or more Personal and/or Team patient lists.",!
+6 SET DIC="^OR(100.21,"
SET DIC(0)="AEQM"
SET DIC("S")="I ""PT""[$E($P(^(0),U,2))"
+7 FOR ORK=1:1
SET ORCT=0
SET DIC("A")="Select LIST "_ORK_": "
DO P1^ORLP0
if ORY<1
QUIT
IF ORCNT>0
WRITE !!,ORCT_" Patients added, "_ORCNT_" total"
+8 if $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+9 IF 'ORCNT
WRITE !!,"List empty.",!
DO END^ORLP0
QUIT
+10 DO PR2^ORLA1(OROPREF)
+11 WRITE !!,"LIST PATIENTS MERGED"
+12 DO LIST^ORLP0
+13 DO STOR
DO END^ORLP0
+14 ;load XUTL with user's primary list
DO BUILD^ORLA1
+15 KILL DIC,ORCEND,ORCLIN,ORCNT,ORCOLW,ORCSTRT,ORCT,ORDEF,ORK,ORPRIM,ORPROV,ORSPEC,ORTITLE,ORUPNM,ORUSSN,ORWARD,Y
+16 QUIT
+17 ;
DEL ;called by option ORLP DELETE - delete a list
+1 IF '$DATA(ORLST)
SET DIC="^OR(100.21,"
SET DIC(0)="AEQM"
SET DIC("S")="I $P(^(0),U,2)'=""P"""
SET DIC("A")="Select Team PATIENT LIST to delete: "
+2 IF $DATA(ORLST)
SET DIC="^OR(100.21,"
SET DIC(0)="AEQM"
SET DIC("S")="I $P(^(0),U,2)=""P""&($D(^OR(100.21,""C"",DUZ,+Y)))"
SET DIC("A")="Select Personal PATIENT LIST to delete: "
+3 DO ^DIC
+4 KILL DIC
+5 IF Y<1
QUIT
+6 SET ORPTEAM=Y
+7 ;
D2 ;
+1 SET %=""
+2 IF $$GET^XPAR("USR.`"_DUZ,"ORLP DEFAULT TEAM",1,"I")=+ORPTEAM
WRITE !!,"This is your primary patient list, are you sure you want to remove it"
SET %=2
DO YN^DICN
+3 IF %=0
WRITE !,"Answer YES if you really want to remove this list."
GOTO D2
+4 IF %'=""
if %'=1
QUIT
+5 WRITE !!,"WARNING - Deleting a patient list will disable access by providers who use the",!,"list as their preferred patient list."
+6 ;
D1 ;
+1 LOCK +^OR(100.21,+ORPTEAM):$GET(DILOCKTM,3)
IF '$TEST
WRITE !,"Another user is editing this entry."
QUIT
+2 WRITE !,"Are you ready to delete list ",$PIECE(ORPTEAM,"^",2)
+3 SET %=2
DO YN^DICN
+4 IF %=0
WRITE !,"Enter YES to delete the list, NO to quit."
GOTO D1
+5 if %'=1
QUIT
+6 WRITE !,"Processing........"
+7 ;L +^OR(100.21,+ORPTEAM)
+8 SET DA=+ORPTEAM
SET DIK="^OR(100.21,"
+9 DO ^DIK
+10 KILL DA,DIC,DIK
+11 ;
+12 ; Next 2 lines added by PKS, 2/8/2000:
+13 WRITE !,"Searching for/removing Consults pointers to deleted team..."
+14 ; Dump pointers to team in file 123.5.
DO CLNLIST^GMRCTU(+ORPTEAM,0)
+15 ;
+16 WRITE !,"List deletion completed.",!
+17 LOCK -^OR(100.21,+ORPTEAM)
+18 ;KILL temporary list
KILL ORPTEAM,ORLPDUZ,Y,XX,^TMP("ORLP",$JOB,"TLIST")
+19 GOTO DEL
+20 QUIT
+21 ;
CLEAR(X) ;called by option ORLP CLEAR - clear active list
+1 IF '$DATA(^XUTL("OR",$JOB,"ORLP"))
WRITE !!,"No list currently defined"
SET X=1
QUIT
+2 FOR
Begin DoDot:1
+3 WRITE !!,"Are you sure you want to clear the current pt selection list"
+4 SET %=2
DO YN^DICN
+5 IF %=-1
SET X=%
QUIT
+6 IF %=0
WRITE !!,"YES will clear the current pt selection list and leave you with a blank slate to work from."
SET X=0
QUIT
+7 IF %=1
KILL ^XUTL("OR",$JOB,"ORLP"),^("ORV"),^("ORU"),^("ORW")
if $DATA(ORCNT)
SET ORCNT=0
WRITE !!,"List cleared"
SET X=%
QUIT
+8 WRITE !!,"Nothing done."
+9 SET X=2
End DoDot:1
if X
QUIT
+10 QUIT
+11 ;
NAMCH(ORTEAM) ; Check for name duplication, proper team type.
+1 ;
+2 ; Variables used:
+3 ;
+4 ; ORTEAM = IEN of team in Team List file (^OR100.21).
+5 ;
+6 ; Check for name duplication and not a "Personal" type team:
+7 IF $PIECE($GET(^OR(100.21,ORTEAM,0)),U,2)'="P"
Begin DoDot:1
+8 WRITE !,ORTNAM," name already used - can't overwrite.",!
+9 KILL X,Y,ORLIST,ORLN
End DoDot:1
QUIT 1
+10 ;
+11 ; Check for "Personal" type but not current user's team:
+12 ; ("CREATOR" field was added later, so not used here.)
+13 ; Is this user's DUZ in "USER" multiple?
+14 IF '$DATA(^OR(100.21,"C",DUZ,ORTEAM))
Begin DoDot:1
+15 WRITE !,ORTNAM," name exists, you are not a user - can't overwrite.",!
+16 KILL X,Y,ORLIST,ORLN
End DoDot:1
QUIT 1
+17 ;
+18 QUIT 0
+19 ;
OWNER ; Get input from CAC for list user/owner.
+1 ;
+2 ; Variables used herein:
+3 ;
+4 ; DIR,X,Y = FM call variables.
+5 ; ORYY = NEW'd in calling routine (ORLP).
+6 ; OROWNER = NEW'd in calling routine (ORLP).
+7 ;
+8 NEW DIR,X,Y
+9 ;
+10 ; Assign variables and get input from CAC for user/owner of list:
+11 ; Default.
SET OROWNER=""
+12 SET DIR(0)="PAO^200,:AEMNQ"
+13 SET DIR("A")=" Enter owner of this Personal type list: "
+14 SET DIR("S")="I $D(X),$D(^VA(200,""AK.PROVIDER"",$P(^(0),U))),$$ACTIVE^XUSER(+Y)"
+15 SET DIR("?")="Only owner you specify can edit list after creation."
+16 DO ^DIR
+17 SET OROWNER=Y
+18 ; Clean up.
KILL DIR,X,Y
+19 ; No acceptable entry.
IF OROWNER<1
SET OROWNER=""
QUIT
+20 ; Selected user's DUZ.
SET OROWNER=+OROWNER
+21 ; Assign CREATOR field.
SET $PIECE(^OR(100.21,+ORYY,0),U,5)=OROWNER
+22 ;
+23 QUIT
+24 ;
