ORLP ;SLC/CLA - Manager for Team List options ; 10/26/17 12:48pm
;;3.0;ORDER ENTRY/RESULTS REPORTING;**47,90,98,243,273,465**;Dec 17, 1997;Build 7
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;DBIA reference section
;10035 - ^DPT(
;2160 - ^XUTL("OR"
;10006 - DIC
;10009 - DICN
;10018 - DIE
;10013 - DIK
;10026 - DIR
;3070 - PTCL^SCAPMC
;
CLEAR ; From TM, MERG^ORLP1, END^ORLP0.
K ^XUTL("OR",$J,"ORLP"),^("ORV"),^("ORU"),^("ORW") S ORCNT=0
Q
;
TM ; From option ORLP TEAM ADD - create/add a team list.
N ORLTYP
D CLEAR
W @IOF,!,"A team list is a list containing patients related to several providers.",!,"These providers are the list's users. You may now create a new team list"
W !,"or add autolinks, users and/or patients to an existing team list. Autolinks",!,"automatically add or remove patients with ADT movements. Users on the list"
W !,"may receive notifications regarding patients on the same list. Please prefix",!,"your list name with 'TEAM' or 'SERVICE' (e.g. TEAM7B, SERVICECARDIOLOGY.)",!
D ASKLIST,END
Q
;
ASKLIST ; Ask for team list.
; NOTE: For new entries, TYPE field is required and trigger
; stuffs CREATOR field with DUZ of current user.
;
AL N DLAYGO,DIC,DIE,DIK,DR,ORFLAG,ORLTNAM,OROWNER,ORROOT,ORDA,ORYY
N DIR S DIR(0)="FAO^3:30",DIR("A")="Enter team list name: "
D ^DIR
I '$D(X)!$D(DIRUT) K DIR,DIRUT Q
S ORLTNAM=$$CHKNAM(Y) ; Check for duplication.
K DIR
N DIC S X=$G(X),(ORROOT,DIC)="^OR(100.21,",DLAYGO=100.21,DIC(0)="LEFQZ" D ^DIC
I '$D(X)!(+Y<0)!$D(DIRUT) K DIRUT Q ; User aborted or problem.
; Check for "Personal" lists (and not a new entry):
I ORLTNAM>0,(+Y>0),$P($G(^OR(100.21,+Y,0)),U,2)="P" W !!," Personal lists cannot be edited here.",! G AL
S (ORYY,TEAM)=Y,ORDA=+Y,TEAM(0)=Y(0),^TMP("ORLP",$J,"TLIST")=+Y K DIC
;
; Lock before allowing editing or creation
L +^OR(100.21,+TEAM):3 I '$T W !?5," Another user is editing this entry." Q
;
; Check for entry of team type (new team entry):
I $P(TEAM,U,3) D Q
.I $P(TEAM(0),U,2)="" D
..SET Y=TEAM,Y(0)=TEAM(0) ; Reassign in case DIE previously called.
..N DIE S DIE=ORROOT,DA=+Y,DR="1 Enter type: ~R" D ^DIE I $O(Y(0)) S DIK=DIE D ^DIK Q
.S (ORLTYP,OROWNER)=""
.S ORLTYP=$P($G(^OR(100.21,+TEAM,0)),U,2) Q:'$L(ORLTYP)
.; Check for "P" type, ask for user/owner input:
.I ORLTYP="P" D
..D OWNER^ORLP1 ; Sets OROWNER variable.
..I +TEAM,'+$G(^OR(100.21,+TEAM,11)) S ^OR(100.21,+TEAM,11)="0^"
.I (ORLTYP="P")&(OROWNER="") S DIK=ORROOT,DA=ORDA D ^DIK Q
.;
.; Allow further editing of autolink type teams:
.I ORLTYP["A" S:'$D(^OR(100.21,+TEAM,2,0)) ^(0)="^100.213AVI^^" D Q
.. D ASKLINK,ASKUSER,ASKDEV,ASKSUB
.;
.; Proceed with editing for "TM" type teams:
.D ASKPT^ORLP00(+TEAM),ASKUSER,ASKDEV
.I ORLTYP="TM" D ASKSUB
;
; For existing teams, display team type:
W !," Type: "_$S($P(Y(0),U,2)="TM":"Manual Team List",$P(Y(0),U,2)="TA":"Autolinked Team List",$P(Y(0),U,2)="MRAL":"Manual Removal Autolinked Team List",1:"(Unknown)")
;
; Allow applicable editing for all types but "TM" teams:
I $P(TEAM(0),U,2)'="TM" D
. D ASKLINK,ASKUSER,ASKDEV
. ;
. ; Editing of "subscription" attribute for "TA" and "MRAL" teams:
. I $P(TEAM(0),U,2)["A" D
. . D ASKSUB
; Proceed with editing for "TM" type teams:
I $P(TEAM(0),U,2)="TM" D ASKPT^ORLP00(+TEAM),ASKUSER,ASKDEV,ASKSUB
Q
;
ASKLINK ; Ask for autolinks.
N DIC,DA,DLAYGO,Y,DUOUT,LVP,LVPT,LNAME
W !
F K DIC,DA,DUOUT D I LVP<1 Q
.S DLAYGO=100.21,DA(1)=+TEAM,DIC="^OR(100.21,"_DA(1)_",2,",DIC(0)="AELMQZ",DIC("A")=" Enter team autolink: "
.D ^DIC S LVP=Y I Y<1 Q
.I $P($G(Y),U,3)=1 D
..S LNAME=Y(0,0)
..I LVP["VA(200" F D Q:'$D(Y)
...S DA(1)=+TEAM,DIE="^OR(100.21,"_DA(1)_",2,",DA(1)=+TEAM,DA=+LVP,DR="1R" D ^DIE I $D(Y) W !," This field is required in order for Provider autolinks to work correctly.",!," Please answer the question."
..S LVPT=$P($G(^OR(100.21,+TEAM,2,+LVP,0)),U,2)
..; For clinics, take a fork in the road:
..I $P($P(LVP,U,2),";",2)="SC(" D BYCL(LVP) Q
..; For autolinks besides clinics, truck on:
..D ADDLPTS
Q
;
ADDLPTS ; Add patients linked to autolink.
W !
W !," [ADT movements linked to "
W !," ",LNAME
W !," will now automatically add patients to this list.]"
S LINK=$P(LVP,U,2),FILE="^"_$P(LINK,";",2),X="",CNT=0
W !!," Adding patients linked to ",LNAME,"..."
W !
I FILE="^DIC(42," D LOOPTS("CN",LNAME) Q
I FILE="^DG(405.4," D LOOPTS("RM",LNAME) Q
I FILE="^VA(200," D Q
. ; Variable LVPT determines if provider pointer is for:
. ; B - Both Primary and Attending
. ; A - Attending
. ; P - Primary
. I LVPT["B" D LOOPTS("APR",+LINK) N CNTAPR S CNTAPR=CNT,CNT=0 D LOOPTS("AAP",+LINK) Q
. I LVPT["P" D LOOPTS("APR",+LINK) Q
. I LVPT["A" D LOOPTS("AAP",+LINK)
I FILE="^DIC(45.7," D LOOPTS("ATR",+LINK) Q
Q
;
BYCL(CLINIC) ; SLC/PKS - 6/99 - Return list of clinic patients by enrollment.
;
; Called by ASKLINK.
;
; Variables used:
;
; CLINIC = Clinic to search.
; ORLIST = Array, returned by call to PTCL^SCAPMC.
; ORERR = Array for errors, returned by call to PTCL^SCAPMC.
; ORRET = Flag for problem with PTCL^SCAPMC call.
; RESULT = Holds result of PTCL^SCAPMC call (1=OK, 0=error).
; RCD = Holder for each record in ^TMP of PTCL^SCAPMC.
; DFN = Patient IEN.
; ALCNT = Count of autolink patients added.
; DUPCNT = Count of duplicate patients already on list.
; X = Temp value holder variable.
;
N DIC,DA,DO,DD,ORLIST,ORERR,RESULT,RCD,DFN,ALCNT,DUPCNT,X,ORRET
;
; Assign clinic variable:
S CLINIC=$P(CLINIC,"^",2)
S CLINIC=$P(CLINIC,";")
;
; Keep user informed:
W !
W !," [Patient enrollments linked to "
W !," ",LNAME
W !," will now automatically add patients to this list.]"
W !
W !," Adding patients enrolled in ",LNAME,"..."
W !
;
; Process the Autolink entries:
K ^TMP("SC TMP LIST") ; Clean up potential leftover data.
S ORRET=1
S RESULT=$$PTCL^SCAPMC(CLINIC,,.ORLIST,.ORERR)
I $L($G(RESULT)) D ; Make sure something was returned.
.I RESULT>0 S ORRET=0 ; Was return value 1 or more?
I ORRET W !," Error in processing - patients will not be added." Q ; Abort if there's a problem.
; Clinic patients should now be in ^TMP("SC TMP LIST",$J file.
;
; Write the patients to the OE/RR LIST file:
S ALCNT=0 ; Initialize autolink counter.
S DUPCNT=0 ; Initialize duplicate counter.
S RCD=0 ; Initialize to start with first data record.
F S RCD=$O(^TMP("SC TMP LIST",$J,RCD)) Q:'RCD D ; Each record.
.S DFN=$P(^TMP("SC TMP LIST",$J,RCD),"^") ; Patient IEN.
.S X=DFN_";DPT(" ; Add ";DPT(" to patient string.
.I $D(^OR(100.21,+TEAM,10,"B",X)) S DUPCNT=DUPCNT+1 Q ; This patient already on list - increment dupe counter.
.S:'$D(^OR(100.21,+TEAM,10,0)) ^(0)="^100.2101AV^^"
.K DIC,DA,DO,DD
.S DA(1)=+TEAM,DIC="^OR(100.21,"_DA(1)_",10,",DIC(0)="L"
.D FILE^DICN
.I +X S ALCNT=ALCNT+1 ; Increment counter.
.Q ; Loop for each record in ^TMP file.
;
; Give user the results:
I ALCNT>0 W !," "_ALCNT_" patient(s) added to list."
I ALCNT=0 W !," No linked patients found."
I DUPCNT>0 W !," "_DUPCNT_" patient(s) already on list."
W !
K ^TMP("SC TMP LIST",$J) ; Clean up ^TMP file entries.
;
Q
;
LOOPTS(REF,DEX) ;
S ORLPT=0 F S ORLPT=$O(^DPT(REF,DEX,ORLPT)) Q:ORLPT'>0 S X=ORLPT_";DPT(" D ADDLOOP
I $D(LVPT),LVPT["B"!(LVPT']"") Q:REF="APR"
I +X W !,$S(+CNT:" "_(+$G(CNTAPR)+(+CNT))_" patient(s) added.",1:" Linked patients already on list.")
E W " No linked patients found."
W !
K DEX,FILE,MSG,REF,X,Y
Q
;
ASKUSER ; From ASKLIST - ask for providers/users.
Q:$D(DTOUT)!($D(DUOUT))
W !
S:'$D(^OR(100.21,+TEAM,1,0)) ^(0)="^100.212PA^^"
K DIC,DA
S DLAYGO=100.212,DA(1)=+TEAM
S DIC("P")="100.212PA",DIC="^OR(100.21,"_DA(1)_",1,",DIC(0)="AELMQ"
S DIC("A")=" Enter team provider/user: "
; SLC/PKS - Next line added on 4/11/2000:
S DIC("S")="I $D(X),$D(^VA(200,""AK.PROVIDER"",$P(^(0),U))),$$ACTIVE^XUSER(+Y)"
F D Q:Y<1
.D ^DIC
.I '(Y<1) W !
K DIC,DA,DLAYGO
Q
;
ASKDEV ; From ASKLIST - ask for device.
;
; New, by PKS - 7/29/99:
Q:$D(DTOUT)!($D(DUOUT)) ; Previous interaction fail?
W !
N DIE,DR
S DIE="^OR(100.21,"
S DA=+TEAM
S DR="1.5 Enter device: "
D ^DIE ; Writes to DEVICE field.
K DIE
Q
;
ASKSUB ; From ASKLIST - Ask re: subscription status.
; (PKS - 8/1999)
;
Q:$D(DTOUT)!($D(DUOUT)) ; Previous interaction fail?
W !
N DIE,DR
S DIE="^OR(100.21,"
S DA=+TEAM
S DR="1.7 Enter subscription status: "
D ^DIE ; Writes to SUBSCRIBE field.
K DIE
;
Q
;
STOR ; From SEQ^ORLP0 - store list in 100.21.
Q:'$D(DUZ)!('ORCNT)
I '$D(TEAM),($D(Y)#2) S TEAM=Y
S DLAYGO=100.21
L +^OR(100.21,+TEAM):$G(DILOCKTM,3) I '$T W !,"Another user is editing this entry." Q
S (CNT,ORLI)=0 F ORLJ=1:1 S ORLI=$O(^XUTL("OR",$J,"ORLP",ORLI)) Q:ORLI<1 I $D(^(ORLI,0)) S X=^(0),X=$P(X,U,3) D ADDLOOP
I $G(X)>0 S MSG=$S(CNT=0:" Patient(s) already on list.",1:" "_CNT_" patient(s) added.") W !?5,MSG
E W !?5," No patients found."
I CNT>0 W !?5," Storing list " W:$D(TEAM) $P(TEAM,U,2)," " W "for future reference..."
L -^OR(100.21,+TEAM)
Q
;
ADDLOOP ; From STOR, LOOPTS - add patients.
Q:$D(^OR(100.21,+TEAM,10,"B",X)) ; Quit if on list.
S:'$D(^OR(100.21,+TEAM,10,0)) ^(0)="^100.2101AV^^"
K DIC,DA,DO,DD
S DA(1)=+TEAM,DIC="^OR(100.21,"_DA(1)_",10,",DIC(0)="L"
D FILE^DICN I Y>0 S:$D(CNT) CNT=CNT+1
Q
;
CHKNAM(X) ; Check for duplicate entry.
N DIC
S X=$G(X)
S DIC="^OR(100.21,"
D ^DIC
S X=+Y
Q X
;
END ;
I $G(TEAM) L -^OR(100.21,+TEAM)
;
END1 K %,CNT,DA,DD,DIC,DO,DIE,DIK,DIR,DR,LINK,ORCNT,ORLI,ORLJ,ORLPT,SEL,TEAM,X,Y,ORBSTG,ORBROOT,DTOUT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORLP 10001 printed Sep 23, 2025@20:07:36 Page 2
ORLP ;SLC/CLA - Manager for Team List options ; 10/26/17 12:48pm
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**47,90,98,243,273,465**;Dec 17, 1997;Build 7
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;DBIA reference section
+5 ;10035 - ^DPT(
+6 ;2160 - ^XUTL("OR"
+7 ;10006 - DIC
+8 ;10009 - DICN
+9 ;10018 - DIE
+10 ;10013 - DIK
+11 ;10026 - DIR
+12 ;3070 - PTCL^SCAPMC
+13 ;
CLEAR ; From TM, MERG^ORLP1, END^ORLP0.
+1 KILL ^XUTL("OR",$JOB,"ORLP"),^("ORV"),^("ORU"),^("ORW")
SET ORCNT=0
+2 QUIT
+3 ;
TM ; From option ORLP TEAM ADD - create/add a team list.
+1 NEW ORLTYP
+2 DO CLEAR
+3 WRITE @IOF,!,"A team list is a list containing patients related to several providers.",!,"These providers are the list's users. You may now create a new team list"
+4 WRITE !,"or add autolinks, users and/or patients to an existing team list. Autolinks",!,"automatically add or remove patients with ADT movements. Users on the list"
+5 WRITE !,"may receive notifications regarding patients on the same list. Please prefix",!,"your list name with 'TEAM' or 'SERVICE' (e.g. TEAM7B, SERVICECARDIOLOGY.)",!
+6 DO ASKLIST
DO END
+7 QUIT
+8 ;
ASKLIST ; Ask for team list.
+1 ; NOTE: For new entries, TYPE field is required and trigger
+2 ; stuffs CREATOR field with DUZ of current user.
+3 ;
AL NEW DLAYGO,DIC,DIE,DIK,DR,ORFLAG,ORLTNAM,OROWNER,ORROOT,ORDA,ORYY
+1 NEW DIR
SET DIR(0)="FAO^3:30"
SET DIR("A")="Enter team list name: "
+2 DO ^DIR
+3 IF '$DATA(X)!$DATA(DIRUT)
KILL DIR,DIRUT
QUIT
+4 ; Check for duplication.
SET ORLTNAM=$$CHKNAM(Y)
+5 KILL DIR
+6 NEW DIC
SET X=$GET(X)
SET (ORROOT,DIC)="^OR(100.21,"
SET DLAYGO=100.21
SET DIC(0)="LEFQZ"
DO ^DIC
+7 ; User aborted or problem.
IF '$DATA(X)!(+Y<0)!$DATA(DIRUT)
KILL DIRUT
QUIT
+8 ; Check for "Personal" lists (and not a new entry):
+9 IF ORLTNAM>0
IF (+Y>0)
IF $PIECE($GET(^OR(100.21,+Y,0)),U,2)="P"
WRITE !!," Personal lists cannot be edited here.",!
GOTO AL
+10 SET (ORYY,TEAM)=Y
SET ORDA=+Y
SET TEAM(0)=Y(0)
SET ^TMP("ORLP",$JOB,"TLIST")=+Y
KILL DIC
+11 ;
+12 ; Lock before allowing editing or creation
+13 LOCK +^OR(100.21,+TEAM):3
IF '$TEST
WRITE !?5," Another user is editing this entry."
QUIT
+14 ;
+15 ; Check for entry of team type (new team entry):
+16 IF $PIECE(TEAM,U,3)
Begin DoDot:1
+17 IF $PIECE(TEAM(0),U,2)=""
Begin DoDot:2
+18 ; Reassign in case DIE previously called.
SET Y=TEAM
SET Y(0)=TEAM(0)
+19 NEW DIE
SET DIE=ORROOT
SET DA=+Y
SET DR="1 Enter type: ~R"
DO ^DIE
IF $ORDER(Y(0))
SET DIK=DIE
DO ^DIK
QUIT
End DoDot:2
+20 SET (ORLTYP,OROWNER)=""
+21 SET ORLTYP=$PIECE($GET(^OR(100.21,+TEAM,0)),U,2)
if '$LENGTH(ORLTYP)
QUIT
+22 ; Check for "P" type, ask for user/owner input:
+23 IF ORLTYP="P"
Begin DoDot:2
+24 ; Sets OROWNER variable.
DO OWNER^ORLP1
+25 IF +TEAM
IF '+$GET(^OR(100.21,+TEAM,11))
SET ^OR(100.21,+TEAM,11)="0^"
End DoDot:2
+26 IF (ORLTYP="P")&(OROWNER="")
SET DIK=ORROOT
SET DA=ORDA
DO ^DIK
QUIT
+27 ;
+28 ; Allow further editing of autolink type teams:
+29 IF ORLTYP["A"
if '$DATA(^OR(100.21,+TEAM,2,0))
SET ^(0)="^100.213AVI^^"
Begin DoDot:2
+30 DO ASKLINK
DO ASKUSER
DO ASKDEV
DO ASKSUB
End DoDot:2
QUIT
+31 ;
+32 ; Proceed with editing for "TM" type teams:
+33 DO ASKPT^ORLP00(+TEAM)
DO ASKUSER
DO ASKDEV
+34 IF ORLTYP="TM"
DO ASKSUB
End DoDot:1
QUIT
+35 ;
+36 ; For existing teams, display team type:
+37 WRITE !," Type: "_$SELECT($PIECE(Y(0),U,2)="TM":"Manual Team List",$PIECE(Y(0),U,2)="TA":"Autolinked Team List",$PIECE(Y(0),U,2)="MRAL":"Manual Removal Autolinked Team List",1:"(Unknown)")
+38 ;
+39 ; Allow applicable editing for all types but "TM" teams:
+40 IF $PIECE(TEAM(0),U,2)'="TM"
Begin DoDot:1
+41 DO ASKLINK
DO ASKUSER
DO ASKDEV
+42 ;
+43 ; Editing of "subscription" attribute for "TA" and "MRAL" teams:
+44 IF $PIECE(TEAM(0),U,2)["A"
Begin DoDot:2
+45 DO ASKSUB
End DoDot:2
End DoDot:1
+46 ; Proceed with editing for "TM" type teams:
+47 IF $PIECE(TEAM(0),U,2)="TM"
DO ASKPT^ORLP00(+TEAM)
DO ASKUSER
DO ASKDEV
DO ASKSUB
+48 QUIT
+49 ;
ASKLINK ; Ask for autolinks.
+1 NEW DIC,DA,DLAYGO,Y,DUOUT,LVP,LVPT,LNAME
+2 WRITE !
+3 FOR
KILL DIC,DA,DUOUT
Begin DoDot:1
+4 SET DLAYGO=100.21
SET DA(1)=+TEAM
SET DIC="^OR(100.21,"_DA(1)_",2,"
SET DIC(0)="AELMQZ"
SET DIC("A")=" Enter team autolink: "
+5 DO ^DIC
SET LVP=Y
IF Y<1
QUIT
+6 IF $PIECE($GET(Y),U,3)=1
Begin DoDot:2
+7 SET LNAME=Y(0,0)
+8 IF LVP["VA(200"
FOR
Begin DoDot:3
+9 SET DA(1)=+TEAM
SET DIE="^OR(100.21,"_DA(1)_",2,"
SET DA(1)=+TEAM
SET DA=+LVP
SET DR="1R"
DO ^DIE
IF $DATA(Y)
WRITE !," This field is required in order for Provider autolinks to work correctly.",!," Please answer the question."
End DoDot:3
if '$DATA(Y)
QUIT
+10 SET LVPT=$PIECE($GET(^OR(100.21,+TEAM,2,+LVP,0)),U,2)
+11 ; For clinics, take a fork in the road:
+12 IF $PIECE($PIECE(LVP,U,2),";",2)="SC("
DO BYCL(LVP)
QUIT
+13 ; For autolinks besides clinics, truck on:
+14 DO ADDLPTS
End DoDot:2
End DoDot:1
IF LVP<1
QUIT
+15 QUIT
+16 ;
ADDLPTS ; Add patients linked to autolink.
+1 WRITE !
+2 WRITE !," [ADT movements linked to "
+3 WRITE !," ",LNAME
+4 WRITE !," will now automatically add patients to this list.]"
+5 SET LINK=$PIECE(LVP,U,2)
SET FILE="^"_$PIECE(LINK,";",2)
SET X=""
SET CNT=0
+6 WRITE !!," Adding patients linked to ",LNAME,"..."
+7 WRITE !
+8 IF FILE="^DIC(42,"
DO LOOPTS("CN",LNAME)
QUIT
+9 IF FILE="^DG(405.4,"
DO LOOPTS("RM",LNAME)
QUIT
+10 IF FILE="^VA(200,"
Begin DoDot:1
+11 ; Variable LVPT determines if provider pointer is for:
+12 ; B - Both Primary and Attending
+13 ; A - Attending
+14 ; P - Primary
+15 IF LVPT["B"
DO LOOPTS("APR",+LINK)
NEW CNTAPR
SET CNTAPR=CNT
SET CNT=0
DO LOOPTS("AAP",+LINK)
QUIT
+16 IF LVPT["P"
DO LOOPTS("APR",+LINK)
QUIT
+17 IF LVPT["A"
DO LOOPTS("AAP",+LINK)
End DoDot:1
QUIT
+18 IF FILE="^DIC(45.7,"
DO LOOPTS("ATR",+LINK)
QUIT
+19 QUIT
+20 ;
BYCL(CLINIC) ; SLC/PKS - 6/99 - Return list of clinic patients by enrollment.
+1 ;
+2 ; Called by ASKLINK.
+3 ;
+4 ; Variables used:
+5 ;
+6 ; CLINIC = Clinic to search.
+7 ; ORLIST = Array, returned by call to PTCL^SCAPMC.
+8 ; ORERR = Array for errors, returned by call to PTCL^SCAPMC.
+9 ; ORRET = Flag for problem with PTCL^SCAPMC call.
+10 ; RESULT = Holds result of PTCL^SCAPMC call (1=OK, 0=error).
+11 ; RCD = Holder for each record in ^TMP of PTCL^SCAPMC.
+12 ; DFN = Patient IEN.
+13 ; ALCNT = Count of autolink patients added.
+14 ; DUPCNT = Count of duplicate patients already on list.
+15 ; X = Temp value holder variable.
+16 ;
+17 NEW DIC,DA,DO,DD,ORLIST,ORERR,RESULT,RCD,DFN,ALCNT,DUPCNT,X,ORRET
+18 ;
+19 ; Assign clinic variable:
+20 SET CLINIC=$PIECE(CLINIC,"^",2)
+21 SET CLINIC=$PIECE(CLINIC,";")
+22 ;
+23 ; Keep user informed:
+24 WRITE !
+25 WRITE !," [Patient enrollments linked to "
+26 WRITE !," ",LNAME
+27 WRITE !," will now automatically add patients to this list.]"
+28 WRITE !
+29 WRITE !," Adding patients enrolled in ",LNAME,"..."
+30 WRITE !
+31 ;
+32 ; Process the Autolink entries:
+33 ; Clean up potential leftover data.
KILL ^TMP("SC TMP LIST")
+34 SET ORRET=1
+35 SET RESULT=$$PTCL^SCAPMC(CLINIC,,.ORLIST,.ORERR)
+36 ; Make sure something was returned.
IF $LENGTH($GET(RESULT))
Begin DoDot:1
+37 ; Was return value 1 or more?
IF RESULT>0
SET ORRET=0
End DoDot:1
+38 ; Abort if there's a problem.
IF ORRET
WRITE !," Error in processing - patients will not be added."
QUIT
+39 ; Clinic patients should now be in ^TMP("SC TMP LIST",$J file.
+40 ;
+41 ; Write the patients to the OE/RR LIST file:
+42 ; Initialize autolink counter.
SET ALCNT=0
+43 ; Initialize duplicate counter.
SET DUPCNT=0
+44 ; Initialize to start with first data record.
SET RCD=0
+45 ; Each record.
FOR
SET RCD=$ORDER(^TMP("SC TMP LIST",$JOB,RCD))
if 'RCD
QUIT
Begin DoDot:1
+46 ; Patient IEN.
SET DFN=$PIECE(^TMP("SC TMP LIST",$JOB,RCD),"^")
+47 ; Add ";DPT(" to patient string.
SET X=DFN_";DPT("
+48 ; This patient already on list - increment dupe counter.
IF $DATA(^OR(100.21,+TEAM,10,"B",X))
SET DUPCNT=DUPCNT+1
QUIT
+49 if '$DATA(^OR(100.21,+TEAM,10,0))
SET ^(0)="^100.2101AV^^"
+50 KILL DIC,DA,DO,DD
+51 SET DA(1)=+TEAM
SET DIC="^OR(100.21,"_DA(1)_",10,"
SET DIC(0)="L"
+52 DO FILE^DICN
+53 ; Increment counter.
IF +X
SET ALCNT=ALCNT+1
+54 ; Loop for each record in ^TMP file.
QUIT
End DoDot:1
+55 ;
+56 ; Give user the results:
+57 IF ALCNT>0
WRITE !," "_ALCNT_" patient(s) added to list."
+58 IF ALCNT=0
WRITE !," No linked patients found."
+59 IF DUPCNT>0
WRITE !," "_DUPCNT_" patient(s) already on list."
+60 WRITE !
+61 ; Clean up ^TMP file entries.
KILL ^TMP("SC TMP LIST",$JOB)
+62 ;
+63 QUIT
+64 ;
LOOPTS(REF,DEX) ;
+1 SET ORLPT=0
FOR
SET ORLPT=$ORDER(^DPT(REF,DEX,ORLPT))
if ORLPT'>0
QUIT
SET X=ORLPT_";DPT("
DO ADDLOOP
+2 IF $DATA(LVPT)
IF LVPT["B"!(LVPT']"")
if REF="APR"
QUIT
+3 IF +X
WRITE !,$SELECT(+CNT:" "_(+$GET(CNTAPR)+(+CNT))_" patient(s) added.",1:" Linked patients already on list.")
+4 IF '$TEST
WRITE " No linked patients found."
+5 WRITE !
+6 KILL DEX,FILE,MSG,REF,X,Y
+7 QUIT
+8 ;
ASKUSER ; From ASKLIST - ask for providers/users.
+1 if $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+2 WRITE !
+3 if '$DATA(^OR(100.21,+TEAM,1,0))
SET ^(0)="^100.212PA^^"
+4 KILL DIC,DA
+5 SET DLAYGO=100.212
SET DA(1)=+TEAM
+6 SET DIC("P")="100.212PA"
SET DIC="^OR(100.21,"_DA(1)_",1,"
SET DIC(0)="AELMQ"
+7 SET DIC("A")=" Enter team provider/user: "
+8 ; SLC/PKS - Next line added on 4/11/2000:
+9 SET DIC("S")="I $D(X),$D(^VA(200,""AK.PROVIDER"",$P(^(0),U))),$$ACTIVE^XUSER(+Y)"
+10 FOR
Begin DoDot:1
+11 DO ^DIC
+12 IF '(Y<1)
WRITE !
End DoDot:1
if Y<1
QUIT
+13 KILL DIC,DA,DLAYGO
+14 QUIT
+15 ;
ASKDEV ; From ASKLIST - ask for device.
+1 ;
+2 ; New, by PKS - 7/29/99:
+3 ; Previous interaction fail?
if $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+4 WRITE !
+5 NEW DIE,DR
+6 SET DIE="^OR(100.21,"
+7 SET DA=+TEAM
+8 SET DR="1.5 Enter device: "
+9 ; Writes to DEVICE field.
DO ^DIE
+10 KILL DIE
+11 QUIT
+12 ;
ASKSUB ; From ASKLIST - Ask re: subscription status.
+1 ; (PKS - 8/1999)
+2 ;
+3 ; Previous interaction fail?
if $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+4 WRITE !
+5 NEW DIE,DR
+6 SET DIE="^OR(100.21,"
+7 SET DA=+TEAM
+8 SET DR="1.7 Enter subscription status: "
+9 ; Writes to SUBSCRIBE field.
DO ^DIE
+10 KILL DIE
+11 ;
+12 QUIT
+13 ;
STOR ; From SEQ^ORLP0 - store list in 100.21.
+1 if '$DATA(DUZ)!('ORCNT)
QUIT
+2 IF '$DATA(TEAM)
IF ($DATA(Y)#2)
SET TEAM=Y
+3 SET DLAYGO=100.21
+4 LOCK +^OR(100.21,+TEAM):$GET(DILOCKTM,3)
IF '$TEST
WRITE !,"Another user is editing this entry."
QUIT
+5 SET (CNT,ORLI)=0
FOR ORLJ=1:1
SET ORLI=$ORDER(^XUTL("OR",$JOB,"ORLP",ORLI))
if ORLI<1
QUIT
IF $DATA(^(ORLI,0))
SET X=^(0)
SET X=$PIECE(X,U,3)
DO ADDLOOP
+6 IF $GET(X)>0
SET MSG=$SELECT(CNT=0:" Patient(s) already on list.",1:" "_CNT_" patient(s) added.")
WRITE !?5,MSG
+7 IF '$TEST
WRITE !?5," No patients found."
+8 IF CNT>0
WRITE !?5," Storing list "
if $DATA(TEAM)
WRITE $PIECE(TEAM,U,2)," "
WRITE "for future reference..."
+9 LOCK -^OR(100.21,+TEAM)
+10 QUIT
+11 ;
ADDLOOP ; From STOR, LOOPTS - add patients.
+1 ; Quit if on list.
if $DATA(^OR(100.21,+TEAM,10,"B",X))
QUIT
+2 if '$DATA(^OR(100.21,+TEAM,10,0))
SET ^(0)="^100.2101AV^^"
+3 KILL DIC,DA,DO,DD
+4 SET DA(1)=+TEAM
SET DIC="^OR(100.21,"_DA(1)_",10,"
SET DIC(0)="L"
+5 DO FILE^DICN
IF Y>0
if $DATA(CNT)
SET CNT=CNT+1
+6 QUIT
+7 ;
CHKNAM(X) ; Check for duplicate entry.
+1 NEW DIC
+2 SET X=$GET(X)
+3 SET DIC="^OR(100.21,"
+4 DO ^DIC
+5 SET X=+Y
+6 QUIT X
+7 ;
END ;
+1 IF $GET(TEAM)
LOCK -^OR(100.21,+TEAM)
+2 ;
END1 KILL %,CNT,DA,DD,DIC,DO,DIE,DIK,DIR,DR,LINK,ORCNT,ORLI,ORLJ,ORLPT,SEL,TEAM,X,Y,ORBSTG,ORBROOT,DTOUT
+1 QUIT
