SCRPITP2 ;ALB/CMM - Individual Team Profile Continued ;7/25/99 18:24
;;5.3;Scheduling;**41,177,520**;AUG 13, 1993;Build 26
;
;Individual Team Profile
;
KEEP(TNODE,TPOS,TM,SCEN) ;
;TNODE - zero node of the team position file entry TPOS
;TPOS - ien of team position file entry TNODE
;TM - ien of team
;
N POS,PPC,CLIEN,PCLIN,MAX,ROL,CIEN,DIV
N SCRDATE,SCI,PROVLIST,SCPROV,SCPTASS,ERR
;
D TEAM(TM,.DIV)
;
S POS=$P(TNODE,"^") ;position name
S ROL=$P($G(^SD(403.46,+$P(TNODE,"^",3),0)),"^") ;standard position
S PPC=$S($P(TNODE,"^",4)'=1:"NPC",+$$OKPREC3^SCMCLK(TPOS,DT)>0:" AP",1:"PCP") ;primary care position
S MAX=$P(TNODE,"^",8)
;
S SCRDATE="SCRDATE",(SCRDATE("BEGIN"),SCRDATE("END"))=DT,SCRDATE("INCL")=0
S SCI="PROVLIST",SCI=$$PRTP^SCAPMC(TPOS,.SCRDATE,SCI,"ERR",1,0)
S SCPROV=$P($G(PROVLIST(1)),U,2)
S SCPTASS=$$PCPOSCNT^SCAPMCU1(TPOS,DT,0)
;
;D FORMAT(POS,PPC,MAX,DIV,TM,TPOS,ROL,SCPROV,SCPTASS)
;
D SETASCL^SCRPRAC2(TPOS,.CNAME,.CLIEN)
S CNAME=$G(CNAME(0))
;S CIEN=+$P(TNODE,"^",9) ;clinic ien ;USING MULTIPLE WITH SD*5.3*520
;S PCLIN=""
;I CIEN>0 S PCLIN=$P($G(^SC(CIEN,0)),"^") ;associated clinic
;
D FORMAT(POS,PPC,MAX,DIV,TM,TPOS,ROL,CNAME,SCPROV,SCPTASS)
N AC
S AC=0
F S AC=$O(CNAME(AC)) Q:AC="" D FORMATAC(POS,DIV,TM,TPOS,CNAME(AC))
K CNAME
Q
;
TEAM(TM,DIV) ;
;
N TMN,TNAME,TDIV,TPHONE,TPC,TSERV,STAT,PUR,MAX,CUR
S TMN=$G(^SCTM(404.51,TM,0)) ;zero node of team file
S TNAME=$P(TMN,"^") ;team name
S DIV=+$P(TMN,"^",7) ;division ien
S TDIV=$P($G(^DIC(4,DIV,0)),"^") ;team division
S TPHONE=$P(TMN,"^",2) ;team phone
S TPC=+$P(TMN,"^",5) ;Primary Care Team ien
S TSERV=$P($G(^DIC(49,+$P(TMN,"^",6),0)),"^") ;Service/section
S STAT=$S(+$$ACTTM^SCMCTMU(TM)=1:"ACTIVE",1:"INACTIVE") ;Team status
S PUR=$P($G(^SD(403.47,+$P(TMN,"^",3),0)),"^")
S MAX=$P(TMN,"^",8)
S CUR=$$TEAMCNT^SCAPMCU1(TM,DT)
D TFORMAT(TNAME,DIV,TDIV,TM,TPHONE,TPC,TSERV,STAT,PUR,MAX,CUR)
;
;GET TEAM DESCRIPTION (WORD PROCESSING FIELD)
D TDESC(TM,DIV)
Q
TDESC(TEM,DIV) ;
;gets team description - word processing field
Q:'$O(^SCTM(404.51,TEM,"D",0))
N EN
S EN=0
S @STORE@(DIV,TEM,"D",0)="Team Description: "
S @STORE@(DIV,TEM,"D",.5)=""
F S EN=$O(^SCTM(404.51,TEM,"D",EN)) Q:EN="" D
.S @STORE@(DIV,TEM,"D",EN)=$G(^SCTM(404.51,TEM,"D",EN,0))
Q
;
TFORMAT(TNAME,DIV,TDIV,TM,TPHONE,TPC,TSERV,STAT,PUR,MAX,CUR) ;
;
I TNAME="" S TNAME="[BAD DATA]"
I TDIV="" S TDIV="[BAD DATA]"
S @STORE@("I",TDIV,DIV)=""
S @STORE@("T",DIV,TNAME,TM)=""
S @STORE@(DIV)="Division: "_TDIV
;
S @STORE@(DIV,TM,"TI",1)="Team Name: "_TNAME
S $E(@STORE@(DIV,TM,"TI",1),44)="Service/Section: "_$E(TSERV,1,30)
S $E(@STORE@(DIV,TM,"TI",1),(120-$L(TPHONE)))="Team Phone: "_TPHONE
S @STORE@(DIV,TM,"TI",2)=""
S @STORE@(DIV,TM,"TI",3)="Team Settings:"
S @STORE@(DIV,TM,"TI",4)=""
S @STORE@(DIV,TM,"TI",5)="Status: "_STAT
S $E(@STORE@(DIV,TM,"TI",5),19)="Maximum Patients: "_MAX
S $E(@STORE@(DIV,TM,"TI",5),47)="Unique Patients Assigned: "_CUR
S $E(@STORE@(DIV,TM,"TI",5),83)="Purpose: "_$E(PUR,1,35)
S @STORE@(DIV,TM,"TI",6)=""
I CUR+1>MAX S @STORE@(DIV,TM,"TI",7)="This team is not accepting patients."
I CUR<MAX,CUR'=MAX S @STORE@(DIV,TM,"TI",7)="This team is still accepting patients."
Q
;
FORMAT(POS,PPC,MAX,DIV,TM,TPOS,ROL,CNAME,SCPROV,SCPTASS) ;
;
I POS="" S POS="[BAD DATA]"
S @STORE@(DIV,TM,"P",POS)=$E(POS,1,24) ;position
S $E(@STORE@(DIV,TM,"P",POS),27)=$E(SCPROV,1,24) ;provider
S $E(@STORE@(DIV,TM,"P",POS),53)=$E(ROL,1,24) ;standard role
S $E(@STORE@(DIV,TM,"P",POS),77)=PPC ;primary care yes/no
S $E(@STORE@(DIV,TM,"P",POS),82)=$J(MAX,6,0) ;number of patients allowed
S $E(@STORE@(DIV,TM,"P",POS),92)=$J(SCPTASS,6,0) ;patients assigned
S $E(@STORE@(DIV,TM,"P",POS),103)=$E(CNAME,1,30)
Q
;
FORMATAC(POS,DIV,TM,TPOS,CNAME) ;clinic name
S $E(@STORE@(DIV,TM,"P",POS,AC),103)=$E(CNAME,1,30)
Q
;
FORHEAD ;
S @STORE@("C",2)="Team Position"
S $E(@STORE@("C",2),27)="Provider Name"
S $E(@STORE@("C",2),53)="Standard Role"
S $E(@STORE@("C",2),77)="PC?"
S $E(@STORE@("C",1),82)="Patients"
S $E(@STORE@("C",2),82)="Allowed"
S $E(@STORE@("C",1),92)="Patients"
S $E(@STORE@("C",2),92)="Assigned"
S $E(@STORE@("C",2),103)="Associated Clinic"
S $P(@STORE@("C",3),"=",133)=""
Q
;
CONT ;Team continuation header
W !,"Team '",TNAME,"' continued..."
COLUMN ;
I STOP Q
N EN
S EN=0
F S EN=$O(@STORE@("C",EN)) Q:EN="" D
.W !,$G(@STORE@("C",EN))
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPITP2 4538 printed Apr 09, 2024@22:04:43 Page 2
SCRPITP2 ;ALB/CMM - Individual Team Profile Continued ;7/25/99 18:24
+1 ;;5.3;Scheduling;**41,177,520**;AUG 13, 1993;Build 26
+2 ;
+3 ;Individual Team Profile
+4 ;
KEEP(TNODE,TPOS,TM,SCEN) ;
+1 ;TNODE - zero node of the team position file entry TPOS
+2 ;TPOS - ien of team position file entry TNODE
+3 ;TM - ien of team
+4 ;
+5 NEW POS,PPC,CLIEN,PCLIN,MAX,ROL,CIEN,DIV
+6 NEW SCRDATE,SCI,PROVLIST,SCPROV,SCPTASS,ERR
+7 ;
+8 DO TEAM(TM,.DIV)
+9 ;
+10 ;position name
SET POS=$PIECE(TNODE,"^")
+11 ;standard position
SET ROL=$PIECE($GET(^SD(403.46,+$PIECE(TNODE,"^",3),0)),"^")
+12 ;primary care position
SET PPC=$SELECT($PIECE(TNODE,"^",4)'=1:"NPC",+$$OKPREC3^SCMCLK(TPOS,DT)>0:" AP",1:"PCP")
+13 SET MAX=$PIECE(TNODE,"^",8)
+14 ;
+15 SET SCRDATE="SCRDATE"
SET (SCRDATE("BEGIN"),SCRDATE("END"))=DT
SET SCRDATE("INCL")=0
+16 SET SCI="PROVLIST"
SET SCI=$$PRTP^SCAPMC(TPOS,.SCRDATE,SCI,"ERR",1,0)
+17 SET SCPROV=$PIECE($GET(PROVLIST(1)),U,2)
+18 SET SCPTASS=$$PCPOSCNT^SCAPMCU1(TPOS,DT,0)
+19 ;
+20 ;D FORMAT(POS,PPC,MAX,DIV,TM,TPOS,ROL,SCPROV,SCPTASS)
+21 ;
+22 DO SETASCL^SCRPRAC2(TPOS,.CNAME,.CLIEN)
+23 SET CNAME=$GET(CNAME(0))
+24 ;S CIEN=+$P(TNODE,"^",9) ;clinic ien ;USING MULTIPLE WITH SD*5.3*520
+25 ;S PCLIN=""
+26 ;I CIEN>0 S PCLIN=$P($G(^SC(CIEN,0)),"^") ;associated clinic
+27 ;
+28 DO FORMAT(POS,PPC,MAX,DIV,TM,TPOS,ROL,CNAME,SCPROV,SCPTASS)
+29 NEW AC
+30 SET AC=0
+31 FOR
SET AC=$ORDER(CNAME(AC))
if AC=""
QUIT
DO FORMATAC(POS,DIV,TM,TPOS,CNAME(AC))
+32 KILL CNAME
+33 QUIT
+34 ;
TEAM(TM,DIV) ;
+1 ;
+2 NEW TMN,TNAME,TDIV,TPHONE,TPC,TSERV,STAT,PUR,MAX,CUR
+3 ;zero node of team file
SET TMN=$GET(^SCTM(404.51,TM,0))
+4 ;team name
SET TNAME=$PIECE(TMN,"^")
+5 ;division ien
SET DIV=+$PIECE(TMN,"^",7)
+6 ;team division
SET TDIV=$PIECE($GET(^DIC(4,DIV,0)),"^")
+7 ;team phone
SET TPHONE=$PIECE(TMN,"^",2)
+8 ;Primary Care Team ien
SET TPC=+$PIECE(TMN,"^",5)
+9 ;Service/section
SET TSERV=$PIECE($GET(^DIC(49,+$PIECE(TMN,"^",6),0)),"^")
+10 ;Team status
SET STAT=$SELECT(+$$ACTTM^SCMCTMU(TM)=1:"ACTIVE",1:"INACTIVE")
+11 SET PUR=$PIECE($GET(^SD(403.47,+$PIECE(TMN,"^",3),0)),"^")
+12 SET MAX=$PIECE(TMN,"^",8)
+13 SET CUR=$$TEAMCNT^SCAPMCU1(TM,DT)
+14 DO TFORMAT(TNAME,DIV,TDIV,TM,TPHONE,TPC,TSERV,STAT,PUR,MAX,CUR)
+15 ;
+16 ;GET TEAM DESCRIPTION (WORD PROCESSING FIELD)
+17 DO TDESC(TM,DIV)
+18 QUIT
TDESC(TEM,DIV) ;
+1 ;gets team description - word processing field
+2 if '$ORDER(^SCTM(404.51,TEM,"D",0))
QUIT
+3 NEW EN
+4 SET EN=0
+5 SET @STORE@(DIV,TEM,"D",0)="Team Description: "
+6 SET @STORE@(DIV,TEM,"D",.5)=""
+7 FOR
SET EN=$ORDER(^SCTM(404.51,TEM,"D",EN))
if EN=""
QUIT
Begin DoDot:1
+8 SET @STORE@(DIV,TEM,"D",EN)=$GET(^SCTM(404.51,TEM,"D",EN,0))
End DoDot:1
+9 QUIT
+10 ;
TFORMAT(TNAME,DIV,TDIV,TM,TPHONE,TPC,TSERV,STAT,PUR,MAX,CUR) ;
+1 ;
+2 IF TNAME=""
SET TNAME="[BAD DATA]"
+3 IF TDIV=""
SET TDIV="[BAD DATA]"
+4 SET @STORE@("I",TDIV,DIV)=""
+5 SET @STORE@("T",DIV,TNAME,TM)=""
+6 SET @STORE@(DIV)="Division: "_TDIV
+7 ;
+8 SET @STORE@(DIV,TM,"TI",1)="Team Name: "_TNAME
+9 SET $EXTRACT(@STORE@(DIV,TM,"TI",1),44)="Service/Section: "_$EXTRACT(TSERV,1,30)
+10 SET $EXTRACT(@STORE@(DIV,TM,"TI",1),(120-$LENGTH(TPHONE)))="Team Phone: "_TPHONE
+11 SET @STORE@(DIV,TM,"TI",2)=""
+12 SET @STORE@(DIV,TM,"TI",3)="Team Settings:"
+13 SET @STORE@(DIV,TM,"TI",4)=""
+14 SET @STORE@(DIV,TM,"TI",5)="Status: "_STAT
+15 SET $EXTRACT(@STORE@(DIV,TM,"TI",5),19)="Maximum Patients: "_MAX
+16 SET $EXTRACT(@STORE@(DIV,TM,"TI",5),47)="Unique Patients Assigned: "_CUR
+17 SET $EXTRACT(@STORE@(DIV,TM,"TI",5),83)="Purpose: "_$EXTRACT(PUR,1,35)
+18 SET @STORE@(DIV,TM,"TI",6)=""
+19 IF CUR+1>MAX
SET @STORE@(DIV,TM,"TI",7)="This team is not accepting patients."
+20 IF CUR<MAX
IF CUR'=MAX
SET @STORE@(DIV,TM,"TI",7)="This team is still accepting patients."
+21 QUIT
+22 ;
FORMAT(POS,PPC,MAX,DIV,TM,TPOS,ROL,CNAME,SCPROV,SCPTASS) ;
+1 ;
+2 IF POS=""
SET POS="[BAD DATA]"
+3 ;position
SET @STORE@(DIV,TM,"P",POS)=$EXTRACT(POS,1,24)
+4 ;provider
SET $EXTRACT(@STORE@(DIV,TM,"P",POS),27)=$EXTRACT(SCPROV,1,24)
+5 ;standard role
SET $EXTRACT(@STORE@(DIV,TM,"P",POS),53)=$EXTRACT(ROL,1,24)
+6 ;primary care yes/no
SET $EXTRACT(@STORE@(DIV,TM,"P",POS),77)=PPC
+7 ;number of patients allowed
SET $EXTRACT(@STORE@(DIV,TM,"P",POS),82)=$JUSTIFY(MAX,6,0)
+8 ;patients assigned
SET $EXTRACT(@STORE@(DIV,TM,"P",POS),92)=$JUSTIFY(SCPTASS,6,0)
+9 SET $EXTRACT(@STORE@(DIV,TM,"P",POS),103)=$EXTRACT(CNAME,1,30)
+10 QUIT
+11 ;
FORMATAC(POS,DIV,TM,TPOS,CNAME) ;clinic name
+1 SET $EXTRACT(@STORE@(DIV,TM,"P",POS,AC),103)=$EXTRACT(CNAME,1,30)
+2 QUIT
+3 ;
FORHEAD ;
+1 SET @STORE@("C",2)="Team Position"
+2 SET $EXTRACT(@STORE@("C",2),27)="Provider Name"
+3 SET $EXTRACT(@STORE@("C",2),53)="Standard Role"
+4 SET $EXTRACT(@STORE@("C",2),77)="PC?"
+5 SET $EXTRACT(@STORE@("C",1),82)="Patients"
+6 SET $EXTRACT(@STORE@("C",2),82)="Allowed"
+7 SET $EXTRACT(@STORE@("C",1),92)="Patients"
+8 SET $EXTRACT(@STORE@("C",2),92)="Assigned"
+9 SET $EXTRACT(@STORE@("C",2),103)="Associated Clinic"
+10 SET $PIECE(@STORE@("C",3),"=",133)=""
+11 QUIT
+12 ;
CONT ;Team continuation header
+1 WRITE !,"Team '",TNAME,"' continued..."
COLUMN ;
+1 IF STOP
QUIT
+2 NEW EN
+3 SET EN=0
+4 FOR
SET EN=$ORDER(@STORE@("C",EN))
if EN=""
QUIT
Begin DoDot:1
+5 WRITE !,$GET(@STORE@("C",EN))
End DoDot:1
+6 QUIT
+7 ;
