ORLP3U1 ; SLC/CLA - Utilities which support OE/RR 3 Team/Patient Lists ; [1/3/01 1:38pm]
;;3.0;ORDER ENTRY/RESULTS REPORTING;**9,63,98**;Dec 17, 1997
;
; SLC/PKS: Changes made - 8/99.
;
Q
;
WINACT(ORWARD) ; returns "1" if ward (^DIC(42,) is inactive
N D0
Q:'$L($G(ORWARD)) 0
S D0=ORWARD
D WIN^DGPMDDCF
Q X
;
USRTMS ; display a user's teams
; Modified by PKS.
N ORUSR,ORUSRN,ORY,ORI,ORCNT,ORTM,ORTMN,ORTYPE
S ORI="",ORCNT=0
W ! K DIC S DIC="^VA(200,",DIC(0)="AEQN",DIC("B")=DUZ
S DIC("A")="Find teams linked to user: "
D ^DIC Q:Y<1 S ORUSR=+Y,ORUSRN=$P(Y,U,2) K DIC,Y,DUOUT,DTOUT
; Call to TEAMPR changed to TEAMPR2 by PKS/slc - 8/1999:
D TEAMPR2^ORQPTQ1(.ORY,ORUSR)
D OUTTMS
Q
;
DUZTMS ; display current user's teams
; Modified by PKS.
N ORUSRN,ORY,ORI,ORCNT,ORTM,ORTMN,ORTYPE
S ORI="",ORCNT=0
; Call to TEAMPR changed to TEAMPR2 by PKS:
D TEAMPR2^ORQPTQ1(.ORY,DUZ)
S ORUSRN=$P(^VA(200,DUZ,0),U)
D OUTTMS
Q
;
USRTMPTS ; display patients linked to a user via teams
; Modified by PKS.
;
; Notes: The TPROVPT^ORQPTQ1 call in USRTMPTS and DUZTMPTS tags
; writes ^TMP("ORLPUPT",$J). Returning, code in OUTPTS4
; here writes a new global, ^XUTL("OR",$J,"ORLP") including
; a "B" index. Modifications by PKS in 8/1999 left this
; functionality unchanged for backwards compatibility. But
; a new "C" index was written to sort for new functionality
; and a new global, ^XUTL("OR",$J,"ORLPTL"), is written in
; order for new output functionality for the display of
; patients sorted alphabetically by teams.
;
; The length of the displayed Team Name is set by the
; variable ORTMNLEN.
;
N ORUSR,ORUSRN,ORI,ORCNT,ORBCNT,ORCCNT,ORPT,ORPTN,ORTMN,ORTMNSTR,ORDATA,ORTMNLEN
S ORTMN="",ORCNT=0,ORBCNT=0,ORCCNT=0,ORTMNLEN=10
W ! K DIC S DIC="^VA(200,",DIC(0)="AEQN",DIC("B")=DUZ
S DIC("A")="Find patients linked via teams to user: "
D ^DIC Q:Y<1 S ORUSR=+Y,ORUSRN=$P(Y,U,2) K DIC,Y,DUOUT,DTOUT
K ^TMP("ORLPUPT",$J)
D TPROVPT^ORQPTQ1(ORUSR)
D OUTPTS
Q
;
DUZTMPTS ; display patients linked to current user via teams
; Modified by PKS.
;
N ORUSR,ORUSRN,ORI,ORCNT,ORBCNT,ORCCNT,ORPT,ORPTN,ORTMN,ORTMNSTR,ORDATA,ORTMNLEN
S ORTMN="",ORCNT=0,ORBCNT=0,ORCCNT=0,ORTMNLEN=10
S ORUSRN=$P(^VA(200,DUZ,0),U)
K ^TMP("ORLPUPT",$J)
D TPROVPT^ORQPTQ1(DUZ)
D OUTPTS
Q
;
OUTTMS ; Output teams.
; Code moved and modified by PKS.
;
K ^XUTL("OR",$J) ; Just in case.
;
F S ORI=$O(ORY(ORI)) Q:ORI="" D
.; Next line changed by PKS:
.S ORTM=$P(ORY(ORI),U),ORTMN=$P(ORY(ORI),U,2),ORTYPE=$P(ORY(ORI),U,3)
.S ORTM=$S($L(ORTM):ORTM,1:1)
.; Next 2 lines new or modified by PKS:
.D TYPESTR ; Assign descriptive type string.
.S ^XUTL("OR",$J,"ORLP",ORTM,0)=ORTMN_U_ORTYPE,ORCNT=ORCNT+1
.S ^XUTL("OR",$J,"ORLP","B",ORTMN,ORTM)=""
S ^XUTL("OR",$J,"ORLP",0)=U_U_ORCNT
;
N COL,HDR,PIE,ROOT
; Next line modified by PKS:
S ROOT="^XUTL(""OR"",$J,""ORLP"",",PIE="1^2",COL=2
S HDR=ORUSRN_" is on the following teams:"
D EN^ORULG(ROOT,PIE,HDR,COL)
K ^XUTL("OR",$J)
Q
;
OUTPTS ; Output patients alphabetically by teams.
; Code moved and modified by PKS.
;
K ^XUTL("OR",$J) ; Just in case.
;
; Order through for each team:
F S ORTMN=$O(^TMP("ORLPUPT",$J,"B",ORTMN)) Q:ORTMN="" D
.S ORTMNSTR=ORTMN ; Check name string (here), length (next line).
.I $L(ORTMN)>ORTMNLEN SET ORTMNSTR=$E(ORTMN,1,ORTMNLEN)_".."
.S ORTMNSTR="("_ORTMNSTR_")" ; Add parenthesis.
.;
.; Order through again for each patient:
.S ORI=""
.F S ORI=$O(^TMP("ORLPUPT",$J,"B",ORTMN,ORI)) Q:ORI="" D
..S ORCNT=ORCNT+1 ; Top-level counter.
..S ORBCNT=ORBCNT+1 ; This node's counter.
..S ORPT=$P(ORI,U,2) ; DFN
..S ORPT=$S($L(ORPT):ORPT,1:1) ; A default of 1.
..S ORPTN=$P(ORI,U) ; Patient name.
..S ^XUTL("OR",$J,"ORLP",ORPT,0)=ORPTN ; Write to ^XUTL.
..S ^XUTL("OR",$J,"ORLP","B",ORPTN,ORPT)="" ; "B" index of ^XUTL.
..;
..; Write new "C" index of ^XUTL:
..S ^XUTL("OR",$J,"ORLP","C",ORTMN_U_ORPTN_U_ORPT)=ORPTN_U_ORTMNSTR
..;
; Write new ^XUTL file entries:
S ORDATA=""
F S ORDATA=$O(^XUTL("OR",$J,"ORLP","C",ORDATA)) Q:ORDATA="" D
.S ORCNT=ORCNT+1 ; Top-level counter.
.S ORCCNT=ORCCNT+1 ; This node's counter.
.S ^XUTL("OR",$J,"ORLPTL",ORCCNT,0)=$G(^XUTL("OR",$J,"ORLP","C",ORDATA))
K ^TMP("ORLPUPT",$J) ; Finished with ^TMP.
;
; Make required FM entries before proceeding:
S ^XUTL("OR",$J,0)=U_U_ORCNT ; Top-level 0-node.
S ^XUTL("OR",$J,"ORLP",0)=U_U_ORBCNT ; Next level 0-node.
S ^XUTL("OR",$J,"ORLPTL",0)=U_U_ORCCNT ; Other level, same.
;
; Check for no entries (in ^XUTL):
I ORCNT=0,ORBCNT=0,ORCCNT=0 D
.K ^XUTL("OR",$J) ; Clean house now.
.S ^XUTL("OR",$J,"ORLPTL",0)=U_U_1 ; Set 0-node.
.;
.; Prepare user message:
.S ^XUTL("OR",$J,"ORLPTL",1,0)="No linked patients found."_U
.; Assign corresponding "B" x-ref:
.S ^XUTL("OR",$J,"ORLPTL","B","No linke patients found.",1)=""
.Q
;
; Call routine for output:
N COL,HDR,PIE,ROOT
S ROOT="^XUTL(""OR"",$J,""ORLPTL"",",PIE="1^2",COL=2
S HDR=ORUSRN_" is linked to the following patients via teams:"
D EN^ORULG(ROOT,PIE,HDR,COL)
K ^XUTL("OR",$J)
Q
;
TYPESTR ; Assign description strings to ORTYPE (Team List type) variables.
; New tag by PKS.
;
I ORTYPE="P" S ORTYPE="(PERSONAL)"
I ORTYPE="TA" S ORTYPE="(AUTOLINK)"
I ORTYPE="TM" S ORTYPE="(MANUAL)"
I ORTYPE="MRAL" S ORTYPE="(MRAL)"
Q
;
ORLP3U1 ; SLC/CLA - Utilities which support OE/RR 3 Team/Patient Lists ; [1/3/01 1:38pm]
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**9,63,98**;Dec 17, 1997
+2 ;
+3 ; SLC/PKS: Changes made - 8/99.
+4 ;
+5 QUIT
+6 ;
WINACT(ORWARD) ; returns "1" if ward (^DIC(42,) is inactive
+1 NEW D0
+2 IF '$LENGTH($GET(ORWARD))
QUIT 0
+3 SET D0=ORWARD
+4 DO WIN^DGPMDDCF
+5 QUIT X
+6 ;
USRTMS ; display a user's teams
+1 ; Modified by PKS.
+2 NEW ORUSR,ORUSRN,ORY,ORI,ORCNT,ORTM,ORTMN,ORTYPE
+3 SET ORI=""
SET ORCNT=0
+4 WRITE !
KILL DIC
SET DIC="^VA(200,"
SET DIC(0)="AEQN"
SET DIC("B")=DUZ
+5 SET DIC("A")="Find teams linked to user: "
+6 DO ^DIC
IF Y<1
QUIT
SET ORUSR=+Y
SET ORUSRN=$PIECE(Y,U,2)
KILL DIC,Y,DUOUT,DTOUT
+7 ; Call to TEAMPR changed to TEAMPR2 by PKS/slc - 8/1999:
+8 DO TEAMPR2^ORQPTQ1(.ORY,ORUSR)
+9 DO OUTTMS
+10 QUIT
+11 ;
DUZTMS ; display current user's teams
+1 ; Modified by PKS.
+2 NEW ORUSRN,ORY,ORI,ORCNT,ORTM,ORTMN,ORTYPE
+3 SET ORI=""
SET ORCNT=0
+4 ; Call to TEAMPR changed to TEAMPR2 by PKS:
+5 DO TEAMPR2^ORQPTQ1(.ORY,DUZ)
+6 SET ORUSRN=$PIECE(^VA(200,DUZ,0),U)
+7 DO OUTTMS
+8 QUIT
+9 ;
USRTMPTS ; display patients linked to a user via teams
+1 ; Modified by PKS.
+2 ;
+3 ; Notes: The TPROVPT^ORQPTQ1 call in USRTMPTS and DUZTMPTS tags
+4 ; writes ^TMP("ORLPUPT",$J). Returning, code in OUTPTS4
+5 ; here writes a new global, ^XUTL("OR",$J,"ORLP") including
+6 ; a "B" index. Modifications by PKS in 8/1999 left this
+7 ; functionality unchanged for backwards compatibility. But
+8 ; a new "C" index was written to sort for new functionality
+9 ; and a new global, ^XUTL("OR",$J,"ORLPTL"), is written in
+10 ; order for new output functionality for the display of
+11 ; patients sorted alphabetically by teams.
+12 ;
+13 ; The length of the displayed Team Name is set by the
+14 ; variable ORTMNLEN.
+15 ;
+16 NEW ORUSR,ORUSRN,ORI,ORCNT,ORBCNT,ORCCNT,ORPT,ORPTN,ORTMN,ORTMNSTR,ORDATA,ORTMNLEN
+17 SET ORTMN=""
SET ORCNT=0
SET ORBCNT=0
SET ORCCNT=0
SET ORTMNLEN=10
+18 WRITE !
KILL DIC
SET DIC="^VA(200,"
SET DIC(0)="AEQN"
SET DIC("B")=DUZ
+19 SET DIC("A")="Find patients linked via teams to user: "
+20 DO ^DIC
IF Y<1
QUIT
SET ORUSR=+Y
SET ORUSRN=$PIECE(Y,U,2)
KILL DIC,Y,DUOUT,DTOUT
+21 KILL ^TMP("ORLPUPT",$JOB)
+22 DO TPROVPT^ORQPTQ1(ORUSR)
+23 DO OUTPTS
+24 QUIT
+25 ;
DUZTMPTS ; display patients linked to current user via teams
+1 ; Modified by PKS.
+2 ;
+3 NEW ORUSR,ORUSRN,ORI,ORCNT,ORBCNT,ORCCNT,ORPT,ORPTN,ORTMN,ORTMNSTR,ORDATA,ORTMNLEN
+4 SET ORTMN=""
SET ORCNT=0
SET ORBCNT=0
SET ORCCNT=0
SET ORTMNLEN=10
+5 SET ORUSRN=$PIECE(^VA(200,DUZ,0),U)
+6 KILL ^TMP("ORLPUPT",$JOB)
+7 DO TPROVPT^ORQPTQ1(DUZ)
+8 DO OUTPTS
+9 QUIT
+10 ;
OUTTMS ; Output teams.
+1 ; Code moved and modified by PKS.
+2 ;
+3 ; Just in case.
KILL ^XUTL("OR",$JOB)
+4 ;
+5 FOR
SET ORI=$ORDER(ORY(ORI))
IF ORI=""
QUIT
Begin DoDot:1
+6 ; Next line changed by PKS:
+7 SET ORTM=$PIECE(ORY(ORI),U)
SET ORTMN=$PIECE(ORY(ORI),U,2)
SET ORTYPE=$PIECE(ORY(ORI),U,3)
+8 SET ORTM=$SELECT($LENGTH(ORTM):ORTM,1:1)
+9 ; Next 2 lines new or modified by PKS:
+10 ; Assign descriptive type string.
DO TYPESTR
+11 SET ^XUTL("OR",$JOB,"ORLP",ORTM,0)=ORTMN_U_ORTYPE
SET ORCNT=ORCNT+1
+12 SET ^XUTL("OR",$JOB,"ORLP","B",ORTMN,ORTM)=""
End DoDot:1
+13 SET ^XUTL("OR",$JOB,"ORLP",0)=U_U_ORCNT
+14 ;
+15 NEW COL,HDR,PIE,ROOT
+16 ; Next line modified by PKS:
+17 SET ROOT="^XUTL(""OR"",$J,""ORLP"","
SET PIE="1^2"
SET COL=2
+18 SET HDR=ORUSRN_" is on the following teams:"
+19 DO EN^ORULG(ROOT,PIE,HDR,COL)
+20 KILL ^XUTL("OR",$JOB)
+21 QUIT
+22 ;
OUTPTS ; Output patients alphabetically by teams.
+1 ; Code moved and modified by PKS.
+2 ;
+3 ; Just in case.
KILL ^XUTL("OR",$JOB)
+4 ;
+5 ; Order through for each team:
+6 FOR
SET ORTMN=$ORDER(^TMP("ORLPUPT",$JOB,"B",ORTMN))
IF ORTMN=""
QUIT
Begin DoDot:1
+7 ; Check name string (here), length (next line).
SET ORTMNSTR=ORTMN
+8 IF $LENGTH(ORTMN)>ORTMNLEN
SET ORTMNSTR=$EXTRACT(ORTMN,1,ORTMNLEN)_".."
+9 ; Add parenthesis.
SET ORTMNSTR="("_ORTMNSTR_")"
+10 ;
+11 ; Order through again for each patient:
+12 SET ORI=""
+13 FOR
SET ORI=$ORDER(^TMP("ORLPUPT",$JOB,"B",ORTMN,ORI))
IF ORI=""
QUIT
Begin DoDot:2
+14 ; Top-level counter.
SET ORCNT=ORCNT+1
+15 ; This node's counter.
SET ORBCNT=ORBCNT+1
+16 ; DFN
SET ORPT=$PIECE(ORI,U,2)
+17 ; A default of 1.
SET ORPT=$SELECT($LENGTH(ORPT):ORPT,1:1)
+18 ; Patient name.
SET ORPTN=$PIECE(ORI,U)
+19 ; Write to ^XUTL.
SET ^XUTL("OR",$JOB,"ORLP",ORPT,0)=ORPTN
+20 ; "B" index of ^XUTL.
SET ^XUTL("OR",$JOB,"ORLP","B",ORPTN,ORPT)=""
+21 ;
+22 ; Write new "C" index of ^XUTL:
+23 SET ^XUTL("OR",$JOB,"ORLP","C",ORTMN_U_ORPTN_U_ORPT)=ORPTN_U_ORTMNSTR
+24 ;
End DoDot:2
End DoDot:1
+25 ; Write new ^XUTL file entries:
+26 SET ORDATA=""
+27 FOR
SET ORDATA=$ORDER(^XUTL("OR",$JOB,"ORLP","C",ORDATA))
IF ORDATA=""
QUIT
Begin DoDot:1
+28 ; Top-level counter.
SET ORCNT=ORCNT+1
+29 ; This node's counter.
SET ORCCNT=ORCCNT+1
+30 SET ^XUTL("OR",$JOB,"ORLPTL",ORCCNT,0)=$GET(^XUTL("OR",$JOB,"ORLP","C",ORDATA))
End DoDot:1
+31 ; Finished with ^TMP.
KILL ^TMP("ORLPUPT",$JOB)
+32 ;
+33 ; Make required FM entries before proceeding:
+34 ; Top-level 0-node.
SET ^XUTL("OR",$JOB,0)=U_U_ORCNT
+35 ; Next level 0-node.
SET ^XUTL("OR",$JOB,"ORLP",0)=U_U_ORBCNT
+36 ; Other level, same.
SET ^XUTL("OR",$JOB,"ORLPTL",0)=U_U_ORCCNT
+37 ;
+38 ; Check for no entries (in ^XUTL):
+39 IF ORCNT=0
IF ORBCNT=0
IF ORCCNT=0
Begin DoDot:1
+40 ; Clean house now.
KILL ^XUTL("OR",$JOB)
+41 ; Set 0-node.
SET ^XUTL("OR",$JOB,"ORLPTL",0)=U_U_1
+42 ;
+43 ; Prepare user message:
+44 SET ^XUTL("OR",$JOB,"ORLPTL",1,0)="No linked patients found."_U
+45 ; Assign corresponding "B" x-ref:
+46 SET ^XUTL("OR",$JOB,"ORLPTL","B","No linke patients found.",1)=""
+47 QUIT
End DoDot:1
+48 ;
+49 ; Call routine for output:
+50 NEW COL,HDR,PIE,ROOT
+51 SET ROOT="^XUTL(""OR"",$J,""ORLPTL"","
SET PIE="1^2"
SET COL=2
+52 SET HDR=ORUSRN_" is linked to the following patients via teams:"
+53 DO EN^ORULG(ROOT,PIE,HDR,COL)
+54 KILL ^XUTL("OR",$JOB)
+55 QUIT
+56 ;
TYPESTR ; Assign description strings to ORTYPE (Team List type) variables.
+1 ; New tag by PKS.
+2 ;
+3 IF ORTYPE="P"
SET ORTYPE="(PERSONAL)"
+4 IF ORTYPE="TA"
SET ORTYPE="(AUTOLINK)"
+5 IF ORTYPE="TM"
SET ORTYPE="(MANUAL)"
+6 IF ORTYPE="MRAL"
SET ORTYPE="(MRAL)"
+7 QUIT
+8 ;
