SCRPTM2 ;ALB/CMM - List of Team's Members Report Continued;01/29/96 ; 29 Jun 99 04:11PM
;;5.3;Scheduling;**41,140,177,520**;AUG 13, 1993;Build 26
;
;List of Team's Members Report
;
PULL(TIEN,PLIST) ;
;TIEN - team file ien
;PLIST - array of positions and their practitioners
;
N PNAME,TPIEN,ACT,INACT,RNAME,UNAME,CNT,NODE,TNODE,PCLIN,TNAME,SCI
N TPHONE,TPC,INS,INAME,PRIEN,PRNAME,OPH,ROOM,SERV,TPNODE,PRCP,PCLASS
;
S CNT=0
F S CNT=$O(@PLIST@(CNT)) Q:CNT=""!(CNT'?.N) D
.;get each practitioner/position
.S NODE=$G(@PLIST@(CNT))
.S TPIEN=+$P(NODE,"^",3) ;team position ien
.S PNAME=$P(NODE,"^",4) ;position name
.S ACT=$P(NODE,"^",9) ;active date (fm)
.I ACT'=""&(ACT'=0) S ACT=$TR($$FMTE^XLFDT(ACT,"5DF")," ","0")
.S INACT=$P(NODE,"^",10) ;inactive date (fm)
.I INACT'=""&(INACT'=0) S INACT=$TR($$FMTE^XLFDT(INACT,"5DF")," ","0")
.S RNAME=$P(NODE,"^",8) ;standard role name
.S UNAME=$P(NODE,"^",6) ;user class name
.S PRIEN=+$P(NODE,"^") ;practitioner ien
.S PRNAME=$P(NODE,"^",2) ;practitioner name
.;
.;Get person class information
.S PCLASS=$$GET^XUA4A72(PRIEN)
.F SCI=1,2,3 S PCLASS(SCI)=$P(PCLASS,U,(SCI+1))
.;
.S TPNODE=$G(^SCTM(404.57,+TPIEN,0))
.D SETASCL^SCRPRAC2(TPIEN,.PCLIN)
.S PCLIN=$G(PCLIN(0))
.;S PCLIN=+$P(TPNODE,"^",9) ;associated clinic ien
.;S PCLIN=$P($G(^SC(PCLIN,0)),"^") ;associated clinic name
.;
.;Get preceptor
.S PRCP=$P($$OKPREC2^SCMCLK(TPIEN,DT),U,2)
.;
.S TNODE=$G(^SCTM(404.51,TIEN,0)) ;team node
.S TNAME=$P(TNODE,"^") ;team name
.S TPHONE=$P(TNODE,"^",2) ;team phone
.S TPC=$S($P(TNODE,"^",5)=1:"YES",1:"NO") ;primary care?
.S INS=+$P(TNODE,"^",7) ;team division ien
.S INAME=$P($G(^DIC(4,INS,0)),"^") ;team division name
.D KTEAM(TNAME,TPHONE,TPC,INAME,TIEN,INS)
.;
.S OPH=$P($G(^VA(200,PRIEN,.13)),"^",2) ;office phone
.S ROOM=$P($G(^VA(200,PRIEN,.14)),"^") ;room
.S SERV=+$P($G(^VA(200,PRIEN,5)),"^") ;service/section ien
.S SERV=$P($G(^DIC(49,SERV,0)),"^") ;service/section name
.;
.D FORMAT(PNAME,TPIEN,PCLIN,RNAME,UNAME,ACT,INACT,PRIEN,PRNAME,OPH,ROOM,SERV,INS,TIEN,PRCP,.PCLASS)
.N SCAC
.S SCAC=0
.F S SCAC=$O(PCLIN(SCAC)) Q:SCAC="" D FORMATAC(INS,TIEN,PRIEN,TPIEN,PCLIN(SCAC))
Q
;
KTEAM(TNAME,TPHONE,TPC,TDIV,TIEN,IEND) ;
;store team information
I TDIV="" S TDIV="[BAD DATA]"
I TNAME="" S TNAME="[BDA DATA]"
S @STORE@("I",TDIV,IEND)=""
S @STORE@("T",IEND,TNAME,TIEN)=""
S @STORE@(IEND)="Division: "_TDIV
S @STORE@(IEND,TIEN,"H1")="Team Name: "_TNAME
S $E(@STORE@(IEND,TIEN,"H1"),40)="Team Phone: "_TPHONE
S @STORE@(IEND,TIEN,"H2")="Primary Care Team: "_TPC
S @STORE@(IEND,TIEN,"H3")=""
S @STORE@(IEND,TIEN,"H4")="Members:"
Q
;
FORMAT(POS,TPIEN,PCLIN,SPOS,UCLASS,BEG,END,PIEN,PRACT,OPH,ROOM,SERV,DIV,TEM,PRCP,PCLASS) ;
;POS - position name
;TPIEN - position ien
;PCLIN - associated clinic
;SPOS - standard position
;UCLASS - user class
;BEG - begin date
;END - end date
;PIEN - ien of new person file
;PRACT - practitioner name
;OPH - office number
;ROOM - room
;SERV - service
;DIV - ien of division
;TEM - ien of team
;PRCP - preceptor
;PCLASS - person class
;
N SCI
I PRACT="" S PRACT="[BAD DATA]"
S @STORE@("PN",DIV,TEM,PRACT,PIEN,TPIEN)=""
S @STORE@(DIV,TEM,PIEN,TPIEN,1)=PRACT
S $E(@STORE@(DIV,TEM,PIEN,TPIEN,1),35)="Position: "_POS
S @STORE@(DIV,TEM,PIEN,TPIEN,2)="Standard Role: "_SPOS
S @STORE@(DIV,TEM,PIEN,TPIEN,3)="User Class: "_UCLASS
S @STORE@(DIV,TEM,PIEN,TPIEN,4)=SERV
S $E(@STORE@(DIV,TEM,PIEN,TPIEN,4),35)="Assoc Clinic: "_PCLIN
S @STORE@(DIV,TEM,PIEN,TPIEN,5)="Office Phone: "_OPH
S $E(@STORE@(DIV,TEM,PIEN,TPIEN,5),35)="Room: "_ROOM
S @STORE@(DIV,TEM,PIEN,TPIEN,6)="Begin Date: "_BEG
S $E(@STORE@(DIV,TEM,PIEN,TPIEN,6),35)="End Date: "_END
S SCI=7
I $L(PRCP) S @STORE@(DIV,TEM,PIEN,TPIEN,SCI)="Preceptor: "_PRCP,SCI=8
I $L(PCLASS(1)) S @STORE@(DIV,TEM,PIEN,TPIEN,SCI)="Person Class: "_PCLASS(1),SCI=SCI+1
I $L(PCLASS(2)) S @STORE@(DIV,TEM,PIEN,TPIEN,SCI)=" "_PCLASS(2),SCI=SCI+1
I $L(PCLASS(3)) S @STORE@(DIV,TEM,PIEN,TPIEN,SCI)=" "_PCLASS(3)
Q
;
FORMATAC(DIV,TEM,PIEN,TPIEN,PCLIN) ;
S $E(@STORE@(DIV,TEM,PIEN,TPIEN,4,SCAC),49)=$E(PCLIN,1,30)
Q
;
NEWP(INST,TEM,TITL,PAGE,HEAD) ;
;new page
D NEWP1^SCRPU3(.PAGE,TITL)
D HEAD1(INST,TEM,.HEAD)
Q
;
HEAD1(INST,TEM,HEAD) ;
;write headings
W !,$G(@STORE@(INST))
N NXT
S NXT="H"
F S NXT=$O(@STORE@(INST,TEM,NXT)) Q:NXT'?1"H".E D
.W !,$G(@STORE@(INST,TEM,NXT))
W ! ;extra line between MEMBERS and practitioner list
S HEAD=1
Q
HOLD1(PAGE,TITL,INST,TEM,HEAD) ;
;device is home, reached end of page
D HOLD^SCRPU3(.PAGE,TITL)
I STOP Q
D HEAD1(INST,TEM,.HEAD)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPTM2 4766 printed Nov 22, 2024@17:52:59 Page 2
SCRPTM2 ;ALB/CMM - List of Team's Members Report Continued;01/29/96 ; 29 Jun 99 04:11PM
+1 ;;5.3;Scheduling;**41,140,177,520**;AUG 13, 1993;Build 26
+2 ;
+3 ;List of Team's Members Report
+4 ;
PULL(TIEN,PLIST) ;
+1 ;TIEN - team file ien
+2 ;PLIST - array of positions and their practitioners
+3 ;
+4 NEW PNAME,TPIEN,ACT,INACT,RNAME,UNAME,CNT,NODE,TNODE,PCLIN,TNAME,SCI
+5 NEW TPHONE,TPC,INS,INAME,PRIEN,PRNAME,OPH,ROOM,SERV,TPNODE,PRCP,PCLASS
+6 ;
+7 SET CNT=0
+8 FOR
SET CNT=$ORDER(@PLIST@(CNT))
if CNT=""!(CNT'?.N)
QUIT
Begin DoDot:1
+9 ;get each practitioner/position
+10 SET NODE=$GET(@PLIST@(CNT))
+11 ;team position ien
SET TPIEN=+$PIECE(NODE,"^",3)
+12 ;position name
SET PNAME=$PIECE(NODE,"^",4)
+13 ;active date (fm)
SET ACT=$PIECE(NODE,"^",9)
+14 IF ACT'=""&(ACT'=0)
SET ACT=$TRANSLATE($$FMTE^XLFDT(ACT,"5DF")," ","0")
+15 ;inactive date (fm)
SET INACT=$PIECE(NODE,"^",10)
+16 IF INACT'=""&(INACT'=0)
SET INACT=$TRANSLATE($$FMTE^XLFDT(INACT,"5DF")," ","0")
+17 ;standard role name
SET RNAME=$PIECE(NODE,"^",8)
+18 ;user class name
SET UNAME=$PIECE(NODE,"^",6)
+19 ;practitioner ien
SET PRIEN=+$PIECE(NODE,"^")
+20 ;practitioner name
SET PRNAME=$PIECE(NODE,"^",2)
+21 ;
+22 ;Get person class information
+23 SET PCLASS=$$GET^XUA4A72(PRIEN)
+24 FOR SCI=1,2,3
SET PCLASS(SCI)=$PIECE(PCLASS,U,(SCI+1))
+25 ;
+26 SET TPNODE=$GET(^SCTM(404.57,+TPIEN,0))
+27 DO SETASCL^SCRPRAC2(TPIEN,.PCLIN)
+28 SET PCLIN=$GET(PCLIN(0))
+29 ;S PCLIN=+$P(TPNODE,"^",9) ;associated clinic ien
+30 ;S PCLIN=$P($G(^SC(PCLIN,0)),"^") ;associated clinic name
+31 ;
+32 ;Get preceptor
+33 SET PRCP=$PIECE($$OKPREC2^SCMCLK(TPIEN,DT),U,2)
+34 ;
+35 ;team node
SET TNODE=$GET(^SCTM(404.51,TIEN,0))
+36 ;team name
SET TNAME=$PIECE(TNODE,"^")
+37 ;team phone
SET TPHONE=$PIECE(TNODE,"^",2)
+38 ;primary care?
SET TPC=$SELECT($PIECE(TNODE,"^",5)=1:"YES",1:"NO")
+39 ;team division ien
SET INS=+$PIECE(TNODE,"^",7)
+40 ;team division name
SET INAME=$PIECE($GET(^DIC(4,INS,0)),"^")
+41 DO KTEAM(TNAME,TPHONE,TPC,INAME,TIEN,INS)
+42 ;
+43 ;office phone
SET OPH=$PIECE($GET(^VA(200,PRIEN,.13)),"^",2)
+44 ;room
SET ROOM=$PIECE($GET(^VA(200,PRIEN,.14)),"^")
+45 ;service/section ien
SET SERV=+$PIECE($GET(^VA(200,PRIEN,5)),"^")
+46 ;service/section name
SET SERV=$PIECE($GET(^DIC(49,SERV,0)),"^")
+47 ;
+48 DO FORMAT(PNAME,TPIEN,PCLIN,RNAME,UNAME,ACT,INACT,PRIEN,PRNAME,OPH,ROOM,SERV,INS,TIEN,PRCP,.PCLASS)
+49 NEW SCAC
+50 SET SCAC=0
+51 FOR
SET SCAC=$ORDER(PCLIN(SCAC))
if SCAC=""
QUIT
DO FORMATAC(INS,TIEN,PRIEN,TPIEN,PCLIN(SCAC))
End DoDot:1
+52 QUIT
+53 ;
KTEAM(TNAME,TPHONE,TPC,TDIV,TIEN,IEND) ;
+1 ;store team information
+2 IF TDIV=""
SET TDIV="[BAD DATA]"
+3 IF TNAME=""
SET TNAME="[BDA DATA]"
+4 SET @STORE@("I",TDIV,IEND)=""
+5 SET @STORE@("T",IEND,TNAME,TIEN)=""
+6 SET @STORE@(IEND)="Division: "_TDIV
+7 SET @STORE@(IEND,TIEN,"H1")="Team Name: "_TNAME
+8 SET $EXTRACT(@STORE@(IEND,TIEN,"H1"),40)="Team Phone: "_TPHONE
+9 SET @STORE@(IEND,TIEN,"H2")="Primary Care Team: "_TPC
+10 SET @STORE@(IEND,TIEN,"H3")=""
+11 SET @STORE@(IEND,TIEN,"H4")="Members:"
+12 QUIT
+13 ;
FORMAT(POS,TPIEN,PCLIN,SPOS,UCLASS,BEG,END,PIEN,PRACT,OPH,ROOM,SERV,DIV,TEM,PRCP,PCLASS) ;
+1 ;POS - position name
+2 ;TPIEN - position ien
+3 ;PCLIN - associated clinic
+4 ;SPOS - standard position
+5 ;UCLASS - user class
+6 ;BEG - begin date
+7 ;END - end date
+8 ;PIEN - ien of new person file
+9 ;PRACT - practitioner name
+10 ;OPH - office number
+11 ;ROOM - room
+12 ;SERV - service
+13 ;DIV - ien of division
+14 ;TEM - ien of team
+15 ;PRCP - preceptor
+16 ;PCLASS - person class
+17 ;
+18 NEW SCI
+19 IF PRACT=""
SET PRACT="[BAD DATA]"
+20 SET @STORE@("PN",DIV,TEM,PRACT,PIEN,TPIEN)=""
+21 SET @STORE@(DIV,TEM,PIEN,TPIEN,1)=PRACT
+22 SET $EXTRACT(@STORE@(DIV,TEM,PIEN,TPIEN,1),35)="Position: "_POS
+23 SET @STORE@(DIV,TEM,PIEN,TPIEN,2)="Standard Role: "_SPOS
+24 SET @STORE@(DIV,TEM,PIEN,TPIEN,3)="User Class: "_UCLASS
+25 SET @STORE@(DIV,TEM,PIEN,TPIEN,4)=SERV
+26 SET $EXTRACT(@STORE@(DIV,TEM,PIEN,TPIEN,4),35)="Assoc Clinic: "_PCLIN
+27 SET @STORE@(DIV,TEM,PIEN,TPIEN,5)="Office Phone: "_OPH
+28 SET $EXTRACT(@STORE@(DIV,TEM,PIEN,TPIEN,5),35)="Room: "_ROOM
+29 SET @STORE@(DIV,TEM,PIEN,TPIEN,6)="Begin Date: "_BEG
+30 SET $EXTRACT(@STORE@(DIV,TEM,PIEN,TPIEN,6),35)="End Date: "_END
+31 SET SCI=7
+32 IF $LENGTH(PRCP)
SET @STORE@(DIV,TEM,PIEN,TPIEN,SCI)="Preceptor: "_PRCP
SET SCI=8
+33 IF $LENGTH(PCLASS(1))
SET @STORE@(DIV,TEM,PIEN,TPIEN,SCI)="Person Class: "_PCLASS(1)
SET SCI=SCI+1
+34 IF $LENGTH(PCLASS(2))
SET @STORE@(DIV,TEM,PIEN,TPIEN,SCI)=" "_PCLASS(2)
SET SCI=SCI+1
+35 IF $LENGTH(PCLASS(3))
SET @STORE@(DIV,TEM,PIEN,TPIEN,SCI)=" "_PCLASS(3)
+36 QUIT
+37 ;
FORMATAC(DIV,TEM,PIEN,TPIEN,PCLIN) ;
+1 SET $EXTRACT(@STORE@(DIV,TEM,PIEN,TPIEN,4,SCAC),49)=$EXTRACT(PCLIN,1,30)
+2 QUIT
+3 ;
NEWP(INST,TEM,TITL,PAGE,HEAD) ;
+1 ;new page
+2 DO NEWP1^SCRPU3(.PAGE,TITL)
+3 DO HEAD1(INST,TEM,.HEAD)
+4 QUIT
+5 ;
HEAD1(INST,TEM,HEAD) ;
+1 ;write headings
+2 WRITE !,$GET(@STORE@(INST))
+3 NEW NXT
+4 SET NXT="H"
+5 FOR
SET NXT=$ORDER(@STORE@(INST,TEM,NXT))
if NXT'?1"H".E
QUIT
Begin DoDot:1
+6 WRITE !,$GET(@STORE@(INST,TEM,NXT))
End DoDot:1
+7 ;extra line between MEMBERS and practitioner list
WRITE !
+8 SET HEAD=1
+9 QUIT
HOLD1(PAGE,TITL,INST,TEM,HEAD) ;
+1 ;device is home, reached end of page
+2 DO HOLD^SCRPU3(.PAGE,TITL)
+3 IF STOP
QUIT
+4 DO HEAD1(INST,TEM,.HEAD)
+5 QUIT
