source: FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORLP2.m@ 1757

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 7.3 KB
Line 
1ORLP2 ; SLC/Staff - Remove Autolinks from Team List ; [1/2/01 11:43am]
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**47,98**;Dec 17, 1997
3 ;from option ORLP REMOVE AUTOLINKS - remove autolinks from team lists
4 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
5 D CLEAR^ORLP
6 W @IOF
7 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"
8 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."
9 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.",!!
10 D ASKLIST I $D(DTOUT)!($G(ORSTOP)) D END Q
11 D ASKLINK(LIST) I $D(DTOUT)!($G(ORSTOP)) D END Q
12 D END
13 Q
14 ;
15ASKLIST ;ask for team list
16 N DIC,DA,DIE
17 S DIC="^OR(100.21,",DIC(0)="AEFMQ",DIC("S")="I $P(^(0),U,2)[""A""",DIC("A")="Enter team list name: "
18 D GETDEF^ORLPL ;get list default, if one exists
19 D ^DIC I Y'>0 S ORSTOP=1 Q
20 S LIST=Y,^TMP("ORLP",$J,"TLIST")=+Y
21 I '$O(^OR(100.21,+LIST,2,0)) W !,"No Autolinks established for this team",! S ORSTOP=1 Q
22 I $O(^OR(100.21,+Y,10,0)) D
23 . F D Q:%
24 .. 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
25 .. I '% W !,"Answer 'YES' to delete existing 'Autolinks' and the associated patients,",!,"'NO' to return to the menus.",!
26 .. S ORSTOP=%'=1
27 Q
28 ;
29ASKLINK(LIST) ;ask for autolinks
30 I +$G(LIST)'>0 Q
31 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: "
32 D ^ORUS S %X="Y(",%Y="ALINK(" D %XY^%RCR I '$O(ALINK(0)) Q
33 K ^TMP("ORLP",$J,"LINK"),^TMP("ORLP",$J,"UNLINK")
34 ;
35 ; Build ^TMP global of all patients that would be on list because
36 ; of the deleted autolinks and delete autolinks
37 S LNK=0 F S LNK=$O(ALINK(LNK)) Q:'LNK D
38 . I $P(^OR(100.21,+LIST,0),U,2)["A",'$O(^OR(100.21,+LIST,2,0)) Q
39 . 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")
40 . 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!"
41 ;
42 ; Build ^TMP global of all patients that would be on list because
43 ; of remaining autolinks.
44 S DA(1)=+LIST,DIC="^OR(100.21,"_DA(1)_",2,",DIC(0)="NZ"
45 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")
46 K DIC
47 ; if the patient is on list because of remaining autolink leave them
48 ; there otherwise delete them
49 S CNT=0,K="" F S K=$O(^TMP("ORLP",$J,"UNLINK",K)) Q:K="" D
50 . 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
51 W !," "_CNT_" patient(s) removed from list.",!
52 Q
53 ;
54PTS(VP,ACT) ;
55 ; set or kill entries out of temp global
56 ; set for patients found to be on a deleted link
57 ; kill for patients to be on another autolink.
58 ; ("Clinic" addition to $SELECT function added by PKS-6/99:)
59 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.]"
60 I VP(1)="^DIC(42," D LOOPTS("CN",LNAME,ACT) Q
61 I VP(1)="^DG(405.4," D LOOPTS("RM",LNAME,ACT) Q
62 I VP(1)="^VA(200," D Q
63 . I $P(VP,U,2)="B" D LOOPTS("APR",+VP,ACT),LOOPTS("AAP",+VP,ACT) Q
64 . I $P(VP,U,2)="P" D LOOPTS("APR",+VP,ACT) Q
65 . I $P(VP,U,2)="A" D LOOPTS("AAP",+VP,ACT) Q
66 I VP(1)="^DIC(45.7," D LOOPTS("ATR",+VP,ACT) Q
67 ; Next line added by PKS on 6/99:
68 I VP(1)="^SC(" D LOOPCL("SC",+VP,ACT) Q
69 Q
70 ;
71LOOPTS(REF,DEX,ACT) ;
72 S ORLPT=0 F S ORLPT=$O(^DPT(REF,DEX,ORLPT)) Q:'ORLPT S X=ORLPT_";DPT(" S ^TMP("ORLP",$J,ACT,X)=""
73 Q
74 ;
75LOOPCL(REF,CLINIC,ACT) ; slc/PKS - 6/99
76 ;
77 ; Add CLINIC linked patients to ^TMP list of all Autolink patients,
78 ; so they can be evaluated for deletion if not duplicated
79 ; by another Autolink.
80 ;
81 ; Variables used:
82 ;
83 ; REF = Passed as "SC" for code clarity but not used herein.
84 ; CLINIC = Clinic to search.
85 ; ACT = Action to take ("LINK" or "UNLINK").
86 ; ORLIST = Array, returned by call to PTCL^SCAPMC.
87 ; ORERR = Array for errors, returned by call to PTCL^SCAPMC.
88 ; RESULT = Holds result of PTCL^SCAPMC call (1=OK, 0=error).
89 ; RCD = Holder for each record in ^TMP of PTCL^SCAPMC.
90 ; PATIENT = Patient IEN.
91 ; X = Temp value holder variable.
92 ;
93 N ORLIST,ORERR,RESULT,RCD,PATIENT,X
94 ;
95 ; Process the Autolink entries:
96 K ^TMP("SC TMP LIST") ; Clean up potential leftover data.
97 S RESULT=$$PTCL^SCAPMC(CLINIC,,.ORLIST,.ORERR)
98 I RESULT=0 W !,"Processing ERROR - patients NOT deleted for this autolink." Q ; Abort if there's a problem.
99 ; Clinic patients should now be in ^TMP("SC TMP LIST",$J file.
100 ;
101 ; Write patients to the new, second ^TMP file for further processing.
102 S RCD=0 ; Initialize.
103 F S RCD=$O(^TMP("SC TMP LIST",$J,RCD)) Q:'RCD D ; Read each record from first ^TMP file.
104 .S PATIENT=$P(^TMP("SC TMP LIST",$J,RCD),"^") ; Patient IEN.
105 .S X=PATIENT_";DPT(" ; Add to patient string.
106 .S ^TMP("ORLP",$J,ACT,X)="" ; Write to second ^TMP file.
107 .Q ; Loop for each record in ^TMP file written to new ^TMP file.
108 ;
109 K ^TMP("SC TMP LIST",$J) ; Clean up first ^TMP file entries.
110 ;
111 Q
112 ;
113REN ; SLC/PKS - 7/99
114 ;
115 ; Allow users to rename a Team List.
116 ; Shows as a selection on menu of ORLP TEAM MENU option,
117 ; Called by option ORLP TEAM RENAME shown on that menu.
118 ;
119 ; Variables used:
120 ;
121 ; DIC = Fileman call.
122 ; Y = DIC output variable containing existing Team List name.
123 ; DIE = Fileman call.
124 ; DR = DIE input variable.
125 ; ORTEAM = Selected team.
126 ; ORNEW = New name to use in renaming of Team List.
127 ;
128 N DIC,DIR,DIE,DR,ORTEAM,ORNEW
129 ;
130 ; Allow selection of a Team List to rename:
131 S DIC="^OR(100.21,"
132 S DIC(0)="AEFQ"
133 S DIC("A")="Enter team list name: "
134 D ^DIC ; Call Fileman function for lookup of Team List name.
135 I ($D(DTOUT))!($D(DUOUT)) Q ; Punt if there's a problem.
136 I '(Y>0) Q ; Punt if no entry selected.
137 S ORTEAM=$P(Y,"^") ; Assign IEN of list selected by user.
138 K DIC
139 ;
140 ; Call Fileman's DIR to get formatted user input:
141 ;
142 S DIR(0)="FA^3:30^KILL:(X?.N)!'(X'?1P.E) X"
143 S DIR("A")="Enter new team list name: "
144 S DIR("?")="Name must be from 3-30 characters and not begin with punctuation or consist wholly of numbers"
145 S DIR("??")=DIR("?")
146 D ^DIR
147 I ($D(DTOUT))!($D(DUOUT)) Q ; Punt if there's a problem.
148 I Y=-1 K DIR Q ; Punt if no input is made.
149 S ORNEW=X
150 K DIR
151 ;
152 L +^OR(100.21,ORTEAM):3 ; Lock the file at the Team List level.
153 I ('$TEST) W !,"Another user is editing this entry." QUIT ; Punt if there's a file locking conflict.
154 ;
155 ; Call Fileman function to implement renaming:
156 S DIE="^OR(100.21,"
157 S DA=ORTEAM
158 S DR=".01///^S X=ORNEW"
159 D ^DIE ; Writes to first field of .01 record.
160 S DR=".1///^SET X=ORNEW"
161 D ^DIE ; Writes to third field of .01 record.
162 ;
163 L -^OR(100.12,ORTEAM) ; Unlock file.
164 K DIE
165 Q
166 ;
167END ;
168 I '$G(LIST) Q
169 L -^OR(100.21,+LIST)
170 Q
171 ;
Note: See TracBrowser for help on using the repository browser.