Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ORLP1

ORLP1.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. ;DBIA reference section
  1. ;2160 - ^XUTL("OR"
  1. ;10006 - DIC
  1. ;10009 - YN^DICN
  1. ;10018 - DIE
  1. ;10013 - DIK
  1. ;10026 - DIR
  1. ;2957 - CLNLIST^GMRCTU
  1. ;2263 - XPAR
  1. ;
  1. STOR ;called by ORLP0 - Store lists
  1. N %,DA,DIC,DIK,DIR,DLAYGO,DR,ORLIST,ORLN,I,J,X,Y
  1. W !!,"Store list for future reference"
  1. S %=1 D YN^DICN Q:%=-1
  1. I %=0 W !,"You may store the newly compiled list. Answer YES or NO." G STOR
  1. Q:%=2
  1. ;
  1. GETNAME ; Call DIR to get user entry for new list name:
  1. N ORTNAM
  1. S ORTNAM=""
  1. N ORNEWL ; Flag used to indicate a new list (v. existing list).
  1. S ORNEWL=1 ; Begin w/assumption of a new list name.
  1. F D Q:$D(X)
  1. .S DIR(0)="FAO^3:30",DIR("A")="Enter a name for this list: "
  1. .D ^DIR
  1. .I '$D(X)!($D(DIRUT)) K DIRUT W " List not permanently stored." Q
  1. .S (ORLN,ORTNAM)=X
  1. .S X=$G(X),DIC="^OR(100.21,"
  1. .D ^DIC
  1. I '$D(X)!(X="") Q
  1. I +Y>0 S ORLIST=+Y,ORLN=$P(Y,U,2) K DIC S Y=ORLIST S ORNEWL=0 ; List name already exists.
  1. ;
  1. OVRWR ;
  1. N ORABORT ; Flag for aborting process.
  1. N ERROR
  1. S ORABORT=0
  1. ;
  1. ; Check for problems with name entry:
  1. I 'ORNEWL D
  1. .I $$NAMCH(+ORLIST) S ORABORT=1
  1. I ORABORT G GETNAME
  1. ;
  1. ; Ask - overwrite if an existing team by that name already?:
  1. I 'ORNEWL D Q:$G(ERROR)
  1. .I $O(^OR(100.21,+Y,10,0)) D Q:%'=1 ; Any patients on list yet?
  1. ..F D Q:%
  1. ...W !,ORLN_" already has patients. Do you want to overwrite it"
  1. ...S %=2 D YN^DICN
  1. ...I %=2!(%=-1) W !,"List ",ORLN," unchanged.",! S ORABORT=1 Q
  1. ...I '% W !,"Answer YES or NO, if you answer YES the list "_ORLN_" will be cleared,",!,"and this temporary list will overwrite it.",! Q
  1. .I ORABORT Q
  1. .L +^OR(100.21,+ORLIST):$G(DILOCKTM,3) I '$T W !,"Another user is editing this entry." S ERROR=1 Q
  1. .I '$D(^OR(100.21,ORLIST,10,0))#2 S ^(0)="^100.2101AV^"
  1. .I '$D(^OR(100.21,ORLIST,1,0))#2 S ^(0)="^100.212PA^"
  1. .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
  1. .L -^OR(100.21,+ORLIST)
  1. I ORABORT G GETNAME
  1. ;
  1. ; If a new list name, write new team into OE/RR LIST file:
  1. I ORNEWL D
  1. .S DIC="^OR(100.21,",DLAYGO=100.21,DIC(0)="LEFQZ"
  1. .D ^DIC
  1. .I (Y<0!'$D(X)) S ORABORT=1 Q ; User aborted or there was a problem.
  1. .S ORLIST=+Y
  1. I ORABORT K DIC Q
  1. ;
  1. ; Assure other required entries if necessary:
  1. I ORNEWL D
  1. .I $P($G(^OR(100.21,+ORLIST,1,0)),U,2)'="P" D
  1. ..S DIE="^OR(100.21,",DA=ORLIST,DR="1///^S X=""P"""
  1. ..D ^DIE
  1. ..K DIE,DA
  1. .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
  1. ;
  1. ; Add selected patients to list (if any):
  1. L +^OR(100.21,+ORLIST):$G(DILOCKTM,3) I '$T W !,"Another user is editing this entry." Q
  1. S ORI=0
  1. 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
  1. K DIC,ORI
  1. L -^OR(100.21,ORLIST)
  1. W !!,"List has been stored."
  1. Q
  1. ;
  1. MERG ;called by option ORLP MERG - merge patient lists
  1. D CLEAR^ORLP ;clear XUTL for merge
  1. D ASK^ORLP0(.X)
  1. I (X<0)!(X>1) Q
  1. S:'$D(ORCNT) ORCNT=0
  1. W @IOF,!,"Merging patients from two or more Personal and/or Team patient lists.",!
  1. S DIC="^OR(100.21,",DIC(0)="AEQM",DIC("S")="I ""PT""[$E($P(^(0),U,2))"
  1. 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"
  1. Q:$D(DTOUT)!($D(DUOUT))
  1. I 'ORCNT W !!,"List empty.",! D END^ORLP0 Q
  1. D PR2^ORLA1(OROPREF)
  1. W !!,"LIST PATIENTS MERGED"
  1. D LIST^ORLP0
  1. D STOR,END^ORLP0
  1. D BUILD^ORLA1 ;load XUTL with user's primary list
  1. K DIC,ORCEND,ORCLIN,ORCNT,ORCOLW,ORCSTRT,ORCT,ORDEF,ORK,ORPRIM,ORPROV,ORSPEC,ORTITLE,ORUPNM,ORUSSN,ORWARD,Y
  1. Q
  1. ;
  1. DEL ;called by option ORLP DELETE - delete a list
  1. 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: "
  1. 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: "
  1. D ^DIC
  1. K DIC
  1. I Y<1 Q
  1. S ORPTEAM=Y
  1. ;
  1. D2 ;
  1. S %=""
  1. 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
  1. I %=0 W !,"Answer YES if you really want to remove this list." G D2
  1. I %'="" Q:%'=1
  1. W !!,"WARNING - Deleting a patient list will disable access by providers who use the",!,"list as their preferred patient list."
  1. ;
  1. D1 ;
  1. L +^OR(100.21,+ORPTEAM):$G(DILOCKTM,3) I '$T W !,"Another user is editing this entry." Q
  1. W !,"Are you ready to delete list ",$P(ORPTEAM,"^",2)
  1. S %=2 D YN^DICN
  1. I %=0 W !,"Enter YES to delete the list, NO to quit." G D1
  1. Q:%'=1
  1. W !,"Processing........"
  1. ;L +^OR(100.21,+ORPTEAM)
  1. S DA=+ORPTEAM,DIK="^OR(100.21,"
  1. D ^DIK
  1. K DA,DIC,DIK
  1. ;
  1. ; Next 2 lines added by PKS, 2/8/2000:
  1. W !,"Searching for/removing Consults pointers to deleted team..."
  1. D CLNLIST^GMRCTU(+ORPTEAM,0) ; Dump pointers to team in file 123.5.
  1. ;
  1. W !,"List deletion completed.",!
  1. L -^OR(100.21,+ORPTEAM)
  1. K ORPTEAM,ORLPDUZ,Y,XX,^TMP("ORLP",$J,"TLIST") ;KILL temporary list
  1. G DEL
  1. Q
  1. ;
  1. CLEAR(X) ;called by option ORLP CLEAR - clear active list
  1. I '$D(^XUTL("OR",$J,"ORLP")) W !!,"No list currently defined" S X=1 Q
  1. F D Q:X
  1. . W !!,"Are you sure you want to clear the current pt selection list"
  1. . S %=2 D YN^DICN
  1. . I %=-1 S X=% Q
  1. . 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
  1. . I %=1 K ^XUTL("OR",$J,"ORLP"),^("ORV"),^("ORU"),^("ORW") S:$D(ORCNT) ORCNT=0 W !!,"List cleared" S X=% Q
  1. . W !!,"Nothing done."
  1. . S X=2
  1. Q
  1. ;
  1. NAMCH(ORTEAM) ; Check for name duplication, proper team type.
  1. ;
  1. ; Variables used:
  1. ;
  1. ; ORTEAM = IEN of team in Team List file (^OR100.21).
  1. ;
  1. ; Check for name duplication and not a "Personal" type team:
  1. I $P($G(^OR(100.21,ORTEAM,0)),U,2)'="P" D Q 1
  1. .W !,ORTNAM," name already used - can't overwrite.",!
  1. .K X,Y,ORLIST,ORLN
  1. ;
  1. ; Check for "Personal" type but not current user's team:
  1. ; ("CREATOR" field was added later, so not used here.)
  1. ; Is this user's DUZ in "USER" multiple?
  1. I '$D(^OR(100.21,"C",DUZ,ORTEAM)) D Q 1
  1. .W !,ORTNAM," name exists, you are not a user - can't overwrite.",!
  1. .K X,Y,ORLIST,ORLN
  1. ;
  1. Q 0
  1. ;
  1. OWNER ; Get input from CAC for list user/owner.
  1. ;
  1. ; Variables used herein:
  1. ;
  1. ; DIR,X,Y = FM call variables.
  1. ; ORYY = NEW'd in calling routine (ORLP).
  1. ; OROWNER = NEW'd in calling routine (ORLP).
  1. ;
  1. N DIR,X,Y
  1. ;
  1. ; Assign variables and get input from CAC for user/owner of list:
  1. S OROWNER="" ; Default.
  1. S DIR(0)="PAO^200,:AEMNQ"
  1. S DIR("A")=" Enter owner of this Personal type list: "
  1. S DIR("S")="I $D(X),$D(^VA(200,""AK.PROVIDER"",$P(^(0),U))),$$ACTIVE^XUSER(+Y)"
  1. S DIR("?")="Only owner you specify can edit list after creation."
  1. D ^DIR
  1. S OROWNER=Y
  1. K DIR,X,Y ; Clean up.
  1. I OROWNER<1 S OROWNER="" Q ; No acceptable entry.
  1. S OROWNER=+OROWNER ; Selected user's DUZ.
  1. S $P(^OR(100.21,+ORYY,0),U,5)=OROWNER ; Assign CREATOR field.
  1. ;
  1. Q
  1. ;