ORLP2 ; SLC/Staff - Remove Autolinks from Team List ; [1/2/01 11:43am]
;;3.0;ORDER ENTRY/RESULTS REPORTING;**47,98**;Dec 17, 1997
;from option ORLP REMOVE AUTOLINKS - remove autolinks from team lists
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
D CLEAR^ORLP
W @IOF
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"
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."
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.",!!
D ASKLIST I $D(DTOUT)!($G(ORSTOP)) D END Q
D ASKLINK(LIST) I $D(DTOUT)!($G(ORSTOP)) D END Q
D END
Q
;
ASKLIST ;ask for team list
N DIC,DA,DIE
S DIC="^OR(100.21,",DIC(0)="AEFMQ",DIC("S")="I $P(^(0),U,2)[""A""",DIC("A")="Enter team list name: "
D GETDEF^ORLPL ;get list default, if one exists
D ^DIC I Y'>0 S ORSTOP=1 Q
S LIST=Y,^TMP("ORLP",$J,"TLIST")=+Y
I '$O(^OR(100.21,+LIST,2,0)) W !,"No Autolinks established for this team",! S ORSTOP=1 Q
I $O(^OR(100.21,+Y,10,0)) D
. F D Q:%
.. 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
.. I '% W !,"Answer 'YES' to delete existing 'Autolinks' and the associated patients,",!,"'NO' to return to the menus.",!
.. S ORSTOP=%'=1
Q
;
ASKLINK(LIST) ;ask for autolinks
I +$G(LIST)'>0 Q
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: "
D ^ORUS S %X="Y(",%Y="ALINK(" D %XY^%RCR I '$O(ALINK(0)) Q
K ^TMP("ORLP",$J,"LINK"),^TMP("ORLP",$J,"UNLINK")
;
; Build ^TMP global of all patients that would be on list because
; of the deleted autolinks and delete autolinks
S LNK=0 F S LNK=$O(ALINK(LNK)) Q:'LNK D
. I $P(^OR(100.21,+LIST,0),U,2)["A",'$O(^OR(100.21,+LIST,2,0)) Q
. 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")
. 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!"
;
; Build ^TMP global of all patients that would be on list because
; of remaining autolinks.
S DA(1)=+LIST,DIC="^OR(100.21,"_DA(1)_",2,",DIC(0)="NZ"
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")
K DIC
; if the patient is on list because of remaining autolink leave them
; there otherwise delete them
S CNT=0,K="" F S K=$O(^TMP("ORLP",$J,"UNLINK",K)) Q:K="" D
. 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
W !," "_CNT_" patient(s) removed from list.",!
Q
;
PTS(VP,ACT) ;
; set or kill entries out of temp global
; set for patients found to be on a deleted link
; kill for patients to be on another autolink.
; ("Clinic" addition to $SELECT function added by PKS-6/99:)
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.]"
I VP(1)="^DIC(42," D LOOPTS("CN",LNAME,ACT) Q
I VP(1)="^DG(405.4," D LOOPTS("RM",LNAME,ACT) Q
I VP(1)="^VA(200," D Q
. I $P(VP,U,2)="B" D LOOPTS("APR",+VP,ACT),LOOPTS("AAP",+VP,ACT) Q
. I $P(VP,U,2)="P" D LOOPTS("APR",+VP,ACT) Q
. I $P(VP,U,2)="A" D LOOPTS("AAP",+VP,ACT) Q
I VP(1)="^DIC(45.7," D LOOPTS("ATR",+VP,ACT) Q
; Next line added by PKS on 6/99:
I VP(1)="^SC(" D LOOPCL("SC",+VP,ACT) Q
Q
;
LOOPTS(REF,DEX,ACT) ;
S ORLPT=0 F S ORLPT=$O(^DPT(REF,DEX,ORLPT)) Q:'ORLPT S X=ORLPT_";DPT(" S ^TMP("ORLP",$J,ACT,X)=""
Q
;
LOOPCL(REF,CLINIC,ACT) ; slc/PKS - 6/99
;
; Add CLINIC linked patients to ^TMP list of all Autolink patients,
; so they can be evaluated for deletion if not duplicated
; by another Autolink.
;
; Variables used:
;
; REF = Passed as "SC" for code clarity but not used herein.
; CLINIC = Clinic to search.
; ACT = Action to take ("LINK" or "UNLINK").
; ORLIST = Array, returned by call to PTCL^SCAPMC.
; ORERR = Array for errors, returned by call to PTCL^SCAPMC.
; RESULT = Holds result of PTCL^SCAPMC call (1=OK, 0=error).
; RCD = Holder for each record in ^TMP of PTCL^SCAPMC.
; PATIENT = Patient IEN.
; X = Temp value holder variable.
;
N ORLIST,ORERR,RESULT,RCD,PATIENT,X
;
; Process the Autolink entries:
K ^TMP("SC TMP LIST") ; Clean up potential leftover data.
S RESULT=$$PTCL^SCAPMC(CLINIC,,.ORLIST,.ORERR)
I RESULT=0 W !,"Processing ERROR - patients NOT deleted for this autolink." Q ; Abort if there's a problem.
; Clinic patients should now be in ^TMP("SC TMP LIST",$J file.
;
; Write patients to the new, second ^TMP file for further processing.
S RCD=0 ; Initialize.
F S RCD=$O(^TMP("SC TMP LIST",$J,RCD)) Q:'RCD D ; Read each record from first ^TMP file.
.S PATIENT=$P(^TMP("SC TMP LIST",$J,RCD),"^") ; Patient IEN.
.S X=PATIENT_";DPT(" ; Add to patient string.
.S ^TMP("ORLP",$J,ACT,X)="" ; Write to second ^TMP file.
.Q ; Loop for each record in ^TMP file written to new ^TMP file.
;
K ^TMP("SC TMP LIST",$J) ; Clean up first ^TMP file entries.
;
Q
;
REN ; SLC/PKS - 7/99
;
; Allow users to rename a Team List.
; Shows as a selection on menu of ORLP TEAM MENU option,
; Called by option ORLP TEAM RENAME shown on that menu.
;
; Variables used:
;
; DIC = Fileman call.
; Y = DIC output variable containing existing Team List name.
; DIE = Fileman call.
; DR = DIE input variable.
; ORTEAM = Selected team.
; ORNEW = New name to use in renaming of Team List.
;
N DIC,DIR,DIE,DR,ORTEAM,ORNEW
;
; Allow selection of a Team List to rename:
S DIC="^OR(100.21,"
S DIC(0)="AEFQ"
S DIC("A")="Enter team list name: "
D ^DIC ; Call Fileman function for lookup of Team List name.
I ($D(DTOUT))!($D(DUOUT)) Q ; Punt if there's a problem.
I '(Y>0) Q ; Punt if no entry selected.
S ORTEAM=$P(Y,"^") ; Assign IEN of list selected by user.
K DIC
;
; Call Fileman's DIR to get formatted user input:
;
S DIR(0)="FA^3:30^KILL:(X?.N)!'(X'?1P.E) X"
S DIR("A")="Enter new team list name: "
S DIR("?")="Name must be from 3-30 characters and not begin with punctuation or consist wholly of numbers"
S DIR("??")=DIR("?")
D ^DIR
I ($D(DTOUT))!($D(DUOUT)) Q ; Punt if there's a problem.
I Y=-1 K DIR Q ; Punt if no input is made.
S ORNEW=X
K DIR
;
L +^OR(100.21,ORTEAM):3 ; Lock the file at the Team List level.
I ('$TEST) W !,"Another user is editing this entry." QUIT ; Punt if there's a file locking conflict.
;
; Call Fileman function to implement renaming:
S DIE="^OR(100.21,"
S DA=ORTEAM
S DR=".01///^S X=ORNEW"
D ^DIE ; Writes to first field of .01 record.
S DR=".1///^SET X=ORNEW"
D ^DIE ; Writes to third field of .01 record.
;
L -^OR(100.12,ORTEAM) ; Unlock file.
K DIE
Q
;
END ;
I '$G(LIST) Q
L -^OR(100.21,+LIST)
Q
;
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
+2 ;from option ORLP REMOVE AUTOLINKS - remove autolinks from team lists
+3 NEW %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
+4 DO CLEAR^ORLP
+5 WRITE @IOF
+6 WRITE !,"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"
+7 WRITE !,"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."
+8 WRITE !!,"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.",!!
+9 DO ASKLIST
IF $DATA(DTOUT)!($GET(ORSTOP))
DO END
QUIT
+10 DO ASKLINK(LIST)
IF $DATA(DTOUT)!($GET(ORSTOP))
DO END
QUIT
+11 DO END
+12 QUIT
+13 ;
ASKLIST ;ask for team list
+1 NEW DIC,DA,DIE
+2 SET DIC="^OR(100.21,"
SET DIC(0)="AEFMQ"
SET DIC("S")="I $P(^(0),U,2)[""A"""
SET DIC("A")="Enter team list name: "
+3 ;get list default, if one exists
DO GETDEF^ORLPL
+4 DO ^DIC
IF Y'>0
SET ORSTOP=1
QUIT
+5 SET LIST=Y
SET ^TMP("ORLP",$JOB,"TLIST")=+Y
+6 IF '$ORDER(^OR(100.21,+LIST,2,0))
WRITE !,"No Autolinks established for this team",!
SET ORSTOP=1
QUIT
+7 IF $ORDER(^OR(100.21,+Y,10,0))
Begin DoDot:1
+8 FOR
Begin DoDot:2
+9 SET ORSTOP=0
WRITE !,"List ",$PIECE(Y,"^",2)," already contains patients and/or users.",!,"Do you want to remove some of them"
SET %=1
DO YN^DICN
IF %=1
LOCK +^OR(100.21,+LIST)
QUIT
+10 IF '%
WRITE !,"Answer 'YES' to delete existing 'Autolinks' and the associated patients,",!,"'NO' to return to the menus.",!
+11 SET ORSTOP=%'=1
End DoDot:2
IF %
QUIT
End DoDot:1
+12 QUIT
+13 ;
ASKLINK(LIST) ;ask for autolinks
+1 IF +$GET(LIST)'>0
QUIT
+2 SET ORUS="^OR(100.21,+LIST,2,"
SET ORUS(0)="40MN"
SET ORUS("T")="W @IOF,?31,""TEAM AUTOLINK LIST"",!"
SET ORUS("A")="Enter Autolink(s) to REMOVE from list: "
+3 DO ^ORUS
SET %X="Y("
SET %Y="ALINK("
DO %XY^%RCR
IF '$ORDER(ALINK(0))
QUIT
+4 KILL ^TMP("ORLP",$JOB,"LINK"),^TMP("ORLP",$JOB,"UNLINK")
+5 ;
+6 ; Build ^TMP global of all patients that would be on list because
+7 ; of the deleted autolinks and delete autolinks
+8 SET LNK=0
FOR
SET LNK=$ORDER(ALINK(LNK))
IF 'LNK
QUIT
Begin DoDot:1
+9 IF $PIECE(^OR(100.21,+LIST,0),U,2)["A"
IF '$ORDER(^OR(100.21,+LIST,2,0))
QUIT
+10 SET VP=$GET(^OR(100.21,+LIST,2,+ALINK(LNK),0))
SET VP(1)="^"_$PIECE($PIECE(VP,";",2),U)
SET VP(2)=+VP
SET LNAME=$PIECE(ALINK(LNK),U,3)
DO PTS(.VP,"UNLINK")
+11 SET DA=+ALINK(LNK)
SET DA(1)=+LIST
SET DIE="^OR(100.21,"_DA(1)_",2,"
SET DR=".01///@"
DO ^DIE
WRITE !," Autolink "_$PIECE(ALINK(LNK),U,3)_" deleted!"
End DoDot:1
+12 ;
+13 ; Build ^TMP global of all patients that would be on list because
+14 ; of remaining autolinks.
+15 SET DA(1)=+LIST
SET DIC="^OR(100.21,"_DA(1)_",2,"
SET DIC(0)="NZ"
+16 SET LST=0
FOR
SET LST=$ORDER(^OR(100.21,+LIST,2,LST))
IF 'LST
QUIT
SET X="`"_LST
DO ^DIC
SET VP=Y(0)
SET VP(1)="^"_$PIECE($PIECE(VP,";",2),U)
SET VP(2)=+VP
SET LNAME=Y(0,0)
DO PTS(.VP,"LINK")
+17 KILL DIC
+18 ; if the patient is on list because of remaining autolink leave them
+19 ; there otherwise delete them
+20 SET CNT=0
SET K=""
FOR
SET K=$ORDER(^TMP("ORLP",$JOB,"UNLINK",K))
IF K=""
QUIT
Begin DoDot:1
+21 IF '$DATA(^TMP("ORLP",$JOB,"LINK",K))
SET DA=$ORDER(^OR(100.21,+LIST,10,"B",K,0))
IF DA
SET DA(1)=+LIST
SET DIK="^OR(100.21,"_DA(1)_",10,"
DO ^DIK
KILL DIK
SET CNT=CNT+1
End DoDot:1
+22 WRITE !," "_CNT_" patient(s) removed from list.",!
+23 QUIT
+24 ;
PTS(VP,ACT) ;
+1 ; set or kill entries out of temp global
+2 ; set for patients found to be on a deleted link
+3 ; kill for patients to be on another autolink.
+4 ; ("Clinic" addition to $SELECT function added by PKS-6/99:)
+5 IF ACT="UNLINK"
WRITE !,"[ADT movements linked to "_$SELECT(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.]"
+6 IF VP(1)="^DIC(42,"
DO LOOPTS("CN",LNAME,ACT)
QUIT
+7 IF VP(1)="^DG(405.4,"
DO LOOPTS("RM",LNAME,ACT)
QUIT
+8 IF VP(1)="^VA(200,"
Begin DoDot:1
+9 IF $PIECE(VP,U,2)="B"
DO LOOPTS("APR",+VP,ACT)
DO LOOPTS("AAP",+VP,ACT)
QUIT
+10 IF $PIECE(VP,U,2)="P"
DO LOOPTS("APR",+VP,ACT)
QUIT
+11 IF $PIECE(VP,U,2)="A"
DO LOOPTS("AAP",+VP,ACT)
QUIT
End DoDot:1
QUIT
+12 IF VP(1)="^DIC(45.7,"
DO LOOPTS("ATR",+VP,ACT)
QUIT
+13 ; Next line added by PKS on 6/99:
+14 IF VP(1)="^SC("
DO LOOPCL("SC",+VP,ACT)
QUIT
+15 QUIT
+16 ;
LOOPTS(REF,DEX,ACT) ;
+1 SET ORLPT=0
FOR
SET ORLPT=$ORDER(^DPT(REF,DEX,ORLPT))
IF 'ORLPT
QUIT
SET X=ORLPT_";DPT("
SET ^TMP("ORLP",$JOB,ACT,X)=""
+2 QUIT
+3 ;
LOOPCL(REF,CLINIC,ACT) ; slc/PKS - 6/99
+1 ;
+2 ; Add CLINIC linked patients to ^TMP list of all Autolink patients,
+3 ; so they can be evaluated for deletion if not duplicated
+4 ; by another Autolink.
+5 ;
+6 ; Variables used:
+7 ;
+8 ; REF = Passed as "SC" for code clarity but not used herein.
+9 ; CLINIC = Clinic to search.
+10 ; ACT = Action to take ("LINK" or "UNLINK").
+11 ; ORLIST = Array, returned by call to PTCL^SCAPMC.
+12 ; ORERR = Array for errors, returned by call to PTCL^SCAPMC.
+13 ; RESULT = Holds result of PTCL^SCAPMC call (1=OK, 0=error).
+14 ; RCD = Holder for each record in ^TMP of PTCL^SCAPMC.
+15 ; PATIENT = Patient IEN.
+16 ; X = Temp value holder variable.
+17 ;
+18 NEW ORLIST,ORERR,RESULT,RCD,PATIENT,X
+19 ;
+20 ; Process the Autolink entries:
+21 ; Clean up potential leftover data.
KILL ^TMP("SC TMP LIST")
+22 SET RESULT=$$PTCL^SCAPMC(CLINIC,,.ORLIST,.ORERR)
+23 ; Abort if there's a problem.
IF RESULT=0
WRITE !,"Processing ERROR - patients NOT deleted for this autolink."
QUIT
+24 ; Clinic patients should now be in ^TMP("SC TMP LIST",$J file.
+25 ;
+26 ; Write patients to the new, second ^TMP file for further processing.
+27 ; Initialize.
SET RCD=0
+28 ; Read each record from first ^TMP file.
FOR
SET RCD=$ORDER(^TMP("SC TMP LIST",$JOB,RCD))
IF 'RCD
QUIT
Begin DoDot:1
+29 ; Patient IEN.
SET PATIENT=$PIECE(^TMP("SC TMP LIST",$JOB,RCD),"^")
+30 ; Add to patient string.
SET X=PATIENT_";DPT("
+31 ; Write to second ^TMP file.
SET ^TMP("ORLP",$JOB,ACT,X)=""
+32 ; Loop for each record in ^TMP file written to new ^TMP file.
QUIT
End DoDot:1
+33 ;
+34 ; Clean up first ^TMP file entries.
KILL ^TMP("SC TMP LIST",$JOB)
+35 ;
+36 QUIT
+37 ;
REN ; SLC/PKS - 7/99
+1 ;
+2 ; Allow users to rename a Team List.
+3 ; Shows as a selection on menu of ORLP TEAM MENU option,
+4 ; Called by option ORLP TEAM RENAME shown on that menu.
+5 ;
+6 ; Variables used:
+7 ;
+8 ; DIC = Fileman call.
+9 ; Y = DIC output variable containing existing Team List name.
+10 ; DIE = Fileman call.
+11 ; DR = DIE input variable.
+12 ; ORTEAM = Selected team.
+13 ; ORNEW = New name to use in renaming of Team List.
+14 ;
+15 NEW DIC,DIR,DIE,DR,ORTEAM,ORNEW
+16 ;
+17 ; Allow selection of a Team List to rename:
+18 SET DIC="^OR(100.21,"
+19 SET DIC(0)="AEFQ"
+20 SET DIC("A")="Enter team list name: "
+21 ; Call Fileman function for lookup of Team List name.
DO ^DIC
+22 ; Punt if there's a problem.
IF ($DATA(DTOUT))!($DATA(DUOUT))
QUIT
+23 ; Punt if no entry selected.
IF '(Y>0)
QUIT
+24 ; Assign IEN of list selected by user.
SET ORTEAM=$PIECE(Y,"^")
+25 KILL DIC
+26 ;
+27 ; Call Fileman's DIR to get formatted user input:
+28 ;
+29 SET DIR(0)="FA^3:30^KILL:(X?.N)!'(X'?1P.E) X"
+30 SET DIR("A")="Enter new team list name: "
+31 SET DIR("?")="Name must be from 3-30 characters and not begin with punctuation or consist wholly of numbers"
+32 SET DIR("??")=DIR("?")
+33 DO ^DIR
+34 ; Punt if there's a problem.
IF ($DATA(DTOUT))!($DATA(DUOUT))
QUIT
+35 ; Punt if no input is made.
IF Y=-1
KILL DIR
QUIT
+36 SET ORNEW=X
+37 KILL DIR
+38 ;
+39 ; Lock the file at the Team List level.
LOCK +^OR(100.21,ORTEAM):3
+40 ; Punt if there's a file locking conflict.
IF ('$TEST)
WRITE !,"Another user is editing this entry."
QUIT
+41 ;
+42 ; Call Fileman function to implement renaming:
+43 SET DIE="^OR(100.21,"
+44 SET DA=ORTEAM
+45 SET DR=".01///^S X=ORNEW"
+46 ; Writes to first field of .01 record.
DO ^DIE
+47 SET DR=".1///^SET X=ORNEW"
+48 ; Writes to third field of .01 record.
DO ^DIE
+49 ;
+50 ; Unlock file.
LOCK -^OR(100.12,ORTEAM)
+51 KILL DIE
+52 QUIT
+53 ;
END ;
+1 IF '$GET(LIST)
QUIT
+2 LOCK -^OR(100.21,+LIST)
+3 QUIT
+4 ;
