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

ORLP2.m

Go to the documentation of this file. 
  1. ORLP2 ; SLC/Staff - Remove Autolinks from Team List ; [1/2/01 11:43am]
  1.  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**47,98**;Dec 17, 1997
  1.  ;from option ORLP REMOVE AUTOLINKS - remove autolinks from team lists
  1.  N %X,%Y,ACT,ALINK,CNT,DA,DIC,DIE,DIK,DIR,DLAYGO,DR,DTOUT,DUOUT,FILE,K,LINK,LIST,LNAME,LNK,LST,ORLPT,ORSTOP,ORUS,REF,TEAM,USER,VP,Y
  1.  D CLEAR^ORLP
  1.  W @IOF
  1.  W !,"A team list is a list containing patients related to several providers.",!,"These providers are the list's users.  You may select one of these lists"
  1.  W !,"and remove one or more autolinks.  Removal of autolinks will stop the",!,"automatic addition or deletion of patients with ADT movements associated",!,"with the deleted autolink."
  1.  W !!,"Patients that were placed on the list using the deleted autolink will be",!,"removed from the list if they were not placed on the list by another Autolink.",!!
  1.  D ASKLIST I $D(DTOUT)!($G(ORSTOP)) D END Q
  1.  D ASKLINK(LIST) I $D(DTOUT)!($G(ORSTOP)) D END Q
  1.  D END
  1.  Q
  1.  ;
  1. ASKLIST ;ask for team list
  1.  N DIC,DA,DIE
  1.  S DIC="^OR(100.21,",DIC(0)="AEFMQ",DIC("S")="I $P(^(0),U,2)[""A""",DIC("A")="Enter team list name: "
  1.  D GETDEF^ORLPL ;get list default, if one exists
  1.  D ^DIC I Y'>0 S ORSTOP=1 Q
  1.  S LIST=Y,^TMP("ORLP",$J,"TLIST")=+Y
  1.  I '$O(^OR(100.21,+LIST,2,0)) W !,"No Autolinks established for this team",! S ORSTOP=1 Q
  1.  I $O(^OR(100.21,+Y,10,0)) D
  1.  . F  D  Q:%
  1.  .. S ORSTOP=0 W !,"List ",$P(Y,"^",2)," already contains patients and/or users.",!,"Do you want to remove some of them" S %=1 D YN^DICN I %=1 L +^OR(100.21,+LIST) Q
  1.  .. I '% W !,"Answer 'YES' to delete existing 'Autolinks' and the associated patients,",!,"'NO' to return to the menus.",!
  1.  .. S ORSTOP=%'=1
  1.  Q
  1.  ;
  1.  I +$G(LIST)'>0 Q
  1.  S ORUS="^OR(100.21,+LIST,2,",ORUS(0)="40MN",ORUS("T")="W @IOF,?31,""TEAM AUTOLINK LIST"",!",ORUS("A")="Enter Autolink(s) to REMOVE from list: "
  1.  D ^ORUS S %X="Y(",%Y="ALINK(" D %XY^%RCR I '$O(ALINK(0)) Q
  1.  K ^TMP("ORLP",$J,"LINK"),^TMP("ORLP",$J,"UNLINK")
  1.  ;
  1.  ; Build ^TMP global of all patients that would be on list because
  1.  ; of the deleted autolinks and delete autolinks
  1.  S LNK=0 F  S LNK=$O(ALINK(LNK)) Q:'LNK  D
  1.  . I $P(^OR(100.21,+LIST,0),U,2)["A",'$O(^OR(100.21,+LIST,2,0)) Q
  1.  . S VP=$G(^OR(100.21,+LIST,2,+ALINK(LNK),0)),VP(1)="^"_$P($P(VP,";",2),U),VP(2)=+VP,LNAME=$P(ALINK(LNK),U,3) D PTS(.VP,"UNLINK")
  1.  . S DA=+ALINK(LNK),DA(1)=+LIST,DIE="^OR(100.21,"_DA(1)_",2,",DR=".01///@" D ^DIE W !,"  Autolink "_$P(ALINK(LNK),U,3)_" deleted!"
  1.  ;
  1.  ; Build ^TMP global of all patients that would be on list because
  1.  ; of remaining autolinks.
  1.  S DA(1)=+LIST,DIC="^OR(100.21,"_DA(1)_",2,",DIC(0)="NZ"
  1.  S LST=0 F  S LST=$O(^OR(100.21,+LIST,2,LST)) Q:'LST  S X="`"_LST D ^DIC   S VP=Y(0),VP(1)="^"_$P($P(VP,";",2),U),VP(2)=+VP,LNAME=Y(0,0) D PTS(.VP,"LINK")
  1.  K DIC
  1.  ; if the patient is on list because of remaining autolink leave them 
  1.  ; there otherwise delete them
  1.  S CNT=0,K="" F  S K=$O(^TMP("ORLP",$J,"UNLINK",K)) Q:K=""  D
  1.  . I '$D(^TMP("ORLP",$J,"LINK",K)) S DA=$O(^OR(100.21,+LIST,10,"B",K,0)) I DA S DA(1)=+LIST,DIK="^OR(100.21,"_DA(1)_",10," D ^DIK K DIK S CNT=CNT+1
  1.  W !,"  "_CNT_" patient(s) removed from list.",!
  1.  Q
  1.  ;
  1. PTS(VP,ACT) ;
  1.  ; set or kill entries out of temp global 
  1.  ; set for patients found to be on a deleted link
  1.  ; kill for patients to be on another autolink.
  1.  ; ("Clinic" addition to $SELECT function added by PKS-6/99:)
  1.  I ACT="UNLINK" W !,"[ADT movements linked to "_$S(VP["DIC(42":"Ward Location ",VP["DG(405":"Room Bed ",VP["VA(200":"Provider ",VP["SC(":"Clinic ",1:"Treating Speciality ")_LNAME_" will now be discontinued.]"
  1.  I VP(1)="^DIC(42," D LOOPTS("CN",LNAME,ACT) Q
  1.  I VP(1)="^DG(405.4," D LOOPTS("RM",LNAME,ACT) Q
  1.  I VP(1)="^VA(200," D  Q
  1.  . I $P(VP,U,2)="B" D LOOPTS("APR",+VP,ACT),LOOPTS("AAP",+VP,ACT) Q
  1.  . I $P(VP,U,2)="P" D LOOPTS("APR",+VP,ACT) Q
  1.  . I $P(VP,U,2)="A" D LOOPTS("AAP",+VP,ACT) Q
  1.  I VP(1)="^DIC(45.7," D LOOPTS("ATR",+VP,ACT) Q
  1.  ; Next line added by PKS on 6/99:
  1.  I VP(1)="^SC(" D LOOPCL("SC",+VP,ACT) Q
  1.  Q
  1.  ;
  1. LOOPTS(REF,DEX,ACT) ;
  1.  S ORLPT=0 F  S ORLPT=$O(^DPT(REF,DEX,ORLPT)) Q:'ORLPT  S X=ORLPT_";DPT(" S ^TMP("ORLP",$J,ACT,X)=""
  1.  Q
  1.  ;
  1. LOOPCL(REF,CLINIC,ACT) ; slc/PKS - 6/99
  1.  ;
  1.  ; Add CLINIC linked patients to ^TMP list of all Autolink patients,
  1.  ;    so they can be evaluated for deletion if not duplicated
  1.  ;    by another Autolink.
  1.  ;
  1.  ; Variables used:
  1.  ;
  1.  ;    REF     = Passed as "SC" for code clarity but not used herein.
  1.  ;    CLINIC  = Clinic to search.
  1.  ;    ACT     = Action to take ("LINK" or "UNLINK").
  1.  ;    ORLIST  = Array, returned by call to PTCL^SCAPMC.
  1.  ;    ORERR   = Array for errors, returned by call to PTCL^SCAPMC.
  1.  ;    RESULT  = Holds result of PTCL^SCAPMC call (1=OK, 0=error).
  1.  ;    RCD     = Holder for each record in ^TMP of PTCL^SCAPMC.
  1.  ;    PATIENT = Patient IEN.
  1.  ;    X       = Temp value holder variable.
  1.  ;
  1.  N ORLIST,ORERR,RESULT,RCD,PATIENT,X
  1.  ;
  1.  ; Process the Autolink entries:
  1.  K ^TMP("SC TMP LIST") ; Clean up potential leftover data.
  1.  S RESULT=$$PTCL^SCAPMC(CLINIC,,.ORLIST,.ORERR)
  1.  I RESULT=0 W !,"Processing ERROR - patients NOT deleted for this autolink." Q  ; Abort if there's a problem.
  1.  ; Clinic patients should now be in ^TMP("SC TMP LIST",$J file.
  1.  ;
  1.  ; Write patients to the new, second ^TMP file for further processing.
  1.  S RCD=0 ; Initialize.
  1.  F  S RCD=$O(^TMP("SC TMP LIST",$J,RCD)) Q:'RCD  D  ; Read each record from first ^TMP file.
  1.  .S PATIENT=$P(^TMP("SC TMP LIST",$J,RCD),"^") ; Patient IEN.
  1.  .S X=PATIENT_";DPT(" ; Add to patient string.
  1.  .S ^TMP("ORLP",$J,ACT,X)="" ; Write to second ^TMP file.
  1.  .Q  ; Loop for each record in ^TMP file written to new ^TMP file.
  1.  ;
  1.  K ^TMP("SC TMP LIST",$J) ; Clean up first ^TMP file entries.
  1.  ;
  1.  Q
  1.  ;
  1. REN ; SLC/PKS - 7/99
  1.  ; 
  1.  ; Allow users to rename a Team List.
  1.  ;    Shows as a selection on menu of ORLP TEAM MENU option,
  1.  ;    Called by option ORLP TEAM RENAME shown on that menu.
  1.  ;
  1.  ; Variables used:
  1.  ;
  1.  ;    DIC    = Fileman call.
  1.  ;    Y      = DIC output variable containing existing Team List name.
  1.  ;    DIE    = Fileman call.
  1.  ;    DR     = DIE input variable.
  1.  ;    ORTEAM = Selected team.
  1.  ;    ORNEW  = New name to use in renaming of Team List.
  1.  ;
  1.  N DIC,DIR,DIE,DR,ORTEAM,ORNEW
  1.  ;
  1.  ; Allow selection of a Team List to rename:
  1.  S DIC="^OR(100.21,"
  1.  S DIC(0)="AEFQ"
  1.  S DIC("A")="Enter team list name: "
  1.  D ^DIC ; Call Fileman function for lookup of Team List name.
  1.  I ($D(DTOUT))!($D(DUOUT)) Q  ; Punt if there's a problem.
  1.  I '(Y>0) Q                   ; Punt if no entry selected.
  1.  S ORTEAM=$P(Y,"^")           ; Assign IEN of list selected by user.
  1.  K DIC
  1.  ;
  1.  ; Call Fileman's DIR to get formatted user input:
  1.  ;
  1.  S DIR(0)="FA^3:30^KILL:(X?.N)!'(X'?1P.E) X"
  1.  S DIR("A")="Enter new team list name: "
  1.  S DIR("?")="Name must be from 3-30 characters and not begin with punctuation or consist wholly of numbers"
  1.  S DIR("??")=DIR("?")
  1.  D ^DIR
  1.  I ($D(DTOUT))!($D(DUOUT)) Q  ; Punt if there's a problem.
  1.  I Y=-1 K DIR Q  ; Punt if no input is made.
  1.  S ORNEW=X
  1.  K DIR
  1.  ;
  1.  L +^OR(100.21,ORTEAM):3 ; Lock the file at the Team List level.
  1.  I ('$TEST) W !,"Another user is editing this entry." QUIT  ; Punt if there's a file locking conflict.
  1.  ;
  1.  ; Call Fileman function to implement renaming:
  1.  S DIE="^OR(100.21,"
  1.  S DA=ORTEAM
  1.  S DR=".01///^S X=ORNEW"
  1.  D ^DIE ; Writes to first field of .01 record.
  1.  S DR=".1///^SET X=ORNEW"
  1.  D ^DIE ; Writes to third field of .01 record.
  1.  ;
  1.  L -^OR(100.12,ORTEAM) ; Unlock file.
  1.  K DIE
  1.  Q
  1.  ;
  1. END ;
  1.  I '$G(LIST) Q
  1.  L -^OR(100.21,+LIST)
  1.  Q
  1.  ;