SCRPSLT2 ;ALB/CMM - Summary Listing of Teams Continued ; 9/15/99 10:43am
;;5.3;Scheduling;**41,174,177,231,520**;AUG 13, 1993;Build 26
;
;Summary Listing of Teams Report
;
KEEP(TNODE,APOS,TPOS,ROL,TM,TPCN,TNPC) ;
;TNODE - zero node of the team position file
;APOS - ien of team position file
;TPOS - ien of position assignment history file
;ROL - ien of role
;TM - ien of team
;
N POS,TNAME,TPHONE,TPC,TDIV,TEN,TMN,DIV,PPC,PCLIN,VAE,PRACT,NPC,MAX
N PCN,ROLN,PRCTP,PRCPC,PRCNPC,PRCPTE,SCPC,SCNPC,XDAT,SCDT,SCI
;
S TEN=+$P(TNODE,"^",2) ;team file pointer
S TMN=$G(^SCTM(404.51,TEN,0))
S TNAME=$P(TMN,"^") ;team name
S DIV=+$P(TMN,"^",7) ;division ien
S TDIV=$P($G(^DIC(4,DIV,0)),"^") ;team division
D KTEAM(TNAME,TDIV,TM,DIV)
;
S POS=$P(TNODE,"^") ;position name
;SD*5.3*231 - call SCMCLK to determine in AP or not
S PPC=$S($P(TNODE,"^",4)<1:"NPC",+$$OKPREC3^SCMCLK(APOS,DT)>0:" AP",1:"PCP") ;PC?
;S PCLIN=$P($G(^SC(+$P(TNODE,"^",9),0)),"^") ;associated clinic
D SETASCL^SCRPRAC2(APOS,.PCLIN)
S PCLIN=$G(PCLIN(0))
S ROLN=$P($G(^SD(403.46,+ROL,0)),U) ;role name
;
S (PRCPC,PRCNPC)="",SCI="^TMP(""SCRATCH"",$J)"
K @SCI
S (SCDT("BEGIN"),SCDT("END"))=DT,SCDT("INCL")=0,SCDT="SCDT"
S SCI=$$PRECHIS^SCMCLK(APOS,.SCDT,SCI)
I SCI=1 S SCI=0 F S SCI=$O(^TMP("SCRATCH",$J,SCI)) Q:'SCI D
.N SCPRCD
.S SCPRCD=^TMP("SCRATCH",$J,SCI),PRCPTE=$P(SCPRCD,U,3) Q:'PRCPTE
.S SCPC=$$PCPOSCNT^SCAPMCU1(PRCPTE,DT,1) ;precepted PC patients
.S:SCPC<0 SCPC=0 S PRCPC=PRCPC+SCPC
.S SCNPC=$$PCPOSCNT^SCAPMCU1(PRCPTE,DT,0) ;all precepted patients
.S:SCNPC<0 SCNPC=0 S SCNPC=SCNPC-SCPC S:SCNPC<0 SCNPC=0
.S PRCNPC=PRCNPC+SCNPC
.Q
;
S XDAT=ROLN_U_PRCPC_U_PRCNPC ;extra data
;
S VAE=+$P($G(^SCTM(404.52,TPOS,0)),"^",3) ;ien of new person file
S PRACT=$P($G(^VA(200,VAE,0)),"^") ;practitioner name
I PRACT="" S PRACT="[Not Assigned]"
;
S MAX=+$P(TNODE,"^",8) I MAX<0 S MAX=0
S PCN=$$PCPOSCNT^SCAPMCU1(APOS,DT) S:PCN=-1 PCN=0
S TPCN(TM)=$G(TPCN(TM))+PCN
S NPC=$$PCPOSCNT^SCAPMCU1(APOS,DT,0) S:NPC=-1 NPC=0
S NPC=NPC-PCN S:NPC<0 NPC=0
S TNPC(TM)=$G(TNPC(TM))+NPC
;
D FORMAT(APOS,POS,PCLIN,VAE,PRACT,PPC,DIV,TM,NPC,MAX,PCN,XDAT)
N SCAC
S SCAC=0
F S SCAC=$O(PCLIN(SCAC)) Q:SCAC="" D FORMATAC(APOS,POS,PCLIN(SCAC),VAE,DIV,TM)
Q
;
TEAMT(TM,TPASS,TMAX,TPCN,TOA,TNPC) ;
;set team totals into global
S @STORE@("TOTALS",TM,"H1")=" Team Totals:"
S @STORE@("TOTALS",TM,"H2")="------------------------------------"
S @STORE@("TOTALS",TM,"H3")=" Primary Care Assignments: "_$J($G(TPCN(TM)),6,0)
S @STORE@("TOTALS",TM,"H4")=" Non-PC Assignments: "_$J($G(TNPC(TM)),6,0)
S @STORE@("TOTALS",TM,"H5")=" Unique Patients Assigned: "_$J($G(TPASS(TM)),6,0)
S @STORE@("TOTALS",TM,"H6")=" Maximum Patients Allowed: "_$J($G(TMAX(TM)),6,0)
S @STORE@("TOTALS",TM,"H7")=" Total Open Assignments: "_$J($G(TOA(TM)),6,0)
Q
;
FORMAT(APOS,POS,PCLIN,VAE,PRACT,PPC,DIV,TM,NPC,MX,PC,XDAT) ;
;
NEW TMP
I PRACT="" S PRACT="Bad Data"
S @STORE@("PN",DIV,TM,PRACT,VAE)=""
S @STORE@(DIV,TM,VAE,APOS)=$E(PRACT,1,20) ;practitioner name
S $E(@STORE@(DIV,TM,VAE,APOS),23)=$E(POS,1,20) ;position
S $E(@STORE@(DIV,TM,VAE,APOS),45)=PPC ;PC?
S $E(@STORE@(DIV,TM,VAE,APOS),50)=$E($P(XDAT,U),1,20) ;role
S $E(@STORE@(DIV,TM,VAE,APOS),72)=$E(PCLIN,1,25) ;assoc. clinic
S $E(@STORE@(DIV,TM,VAE,APOS),99)=$J(MX,6,0) ;max pts.
S $E(@STORE@(DIV,TM,VAE,APOS),107)=$J(PC,5,0) ;PC pts.
S $E(@STORE@(DIV,TM,VAE,APOS),114)=$J(NPC,5,0) ;non-PC pts.
;
;bp/djb 'Precepted Patients' column should be zero for APs.
;Old code begins
;S $E(@STORE@(DIV,TM,VAE,APOS),121)=$J($P(XDAT,U,2),5,0) ;precept PC
;S $E(@STORE@(DIV,TM,VAE,APOS),128)=$J($P(XDAT,U,3),5,0) ;precept NPC
;Old code ends
;New code begins
S (TMP(1),TMP(2))=0 I PPC'["AP" D ;APs should be zero
.S TMP(1)=$P(XDAT,U,2)
.S TMP(2)=$P(XDAT,U,3)
S $E(@STORE@(DIV,TM,VAE,APOS),121)=$J(TMP(1),5,0) ;precepted PC
S $E(@STORE@(DIV,TM,VAE,APOS),128)=$J(TMP(2),5,0) ;precepted NPC
;New code ends
Q
FORMATAC(APOS,POS,PCLIN,VAE,DIV,TM) ;clinic multiples
S $E(@STORE@(DIV,TM,VAE,APOS,SCAC),72)=$E(PCLIN,1,30)
Q
;
TOTAL(INST,TEM) ;
;Prints team totals
N NXT
S NXT=""
W !
F S NXT=$O(@STORE@("TOTALS",TEM,NXT)) Q:NXT="" D
.;bp/djb Stop displaying certain 'Team Totals:' lines.
.;New code begin
.Q:$G(@STORE@("TOTALS",TEM,NXT))["Unique Patients Assigned"
.Q:$G(@STORE@("TOTALS",TEM,NXT))["Maximum Patients Allowed"
.Q:$G(@STORE@("TOTALS",TEM,NXT))["Total Open Assignments"
.;New code end
.W !,$G(@STORE@("TOTALS",TEM,NXT))
W !
Q
;
KTEAM(TNAME,TDIV,TIEN,IEND) ;
;store team information
I TNAME="" S TNAME="[BAD DATA]"
I TDIV="" S TDIV="[BAD DATA]"
S @STORE@("I",TDIV,IEND)=""
S @STORE@("T",IEND,TNAME,TIEN)=""
S @STORE@(IEND)=" Division: "_TDIV
S @STORE@(IEND,TIEN)="Team Name: "_TNAME
Q
;
FORHEAD ;
S @STORE@("H3")="Practitioner"
S $E(@STORE@("H3"),23)="Position"
S $E(@STORE@("H3"),45)="PC?"
S $E(@STORE@("H3"),50)="Standard Role"
S $E(@STORE@("H3"),72)="Associated Clinic"
S $E(@STORE@("H1"),101)="Max."
S $E(@STORE@("H2"),101)="Pts."
S $E(@STORE@("H3"),99)="Allow."
S $E(@STORE@("H1"),107)="--Assigned--"
S $E(@STORE@("H2"),107)="--Patients--"
S $E(@STORE@("H3"),107)="PC NonPC"
S $E(@STORE@("H1"),121)="--Precepted-"
S $E(@STORE@("H2"),121)="--Patients--"
S $E(@STORE@("H3"),121)="PC NonPC"
S $P(@STORE@("H4"),"=",133)=""
Q
N NXT
S NXT="H",TEND=$G(TEND)
W !!,@STORE@(INST)
W !!,@STORE@(INST,TEM)
I 'TEND F S NXT=$O(@STORE@(NXT)) Q:NXT'?1"H".E D
.W !,@STORE@(NXT)
W !
Q
NEWP(INST,TEM,TITL,PAGE,TEND) ;
S TEND=$G(TEND)
D NEWP1^SCRPU3(.PAGE,TITL)
I STOP Q
D HEADER(INST,TEM,TEND)
Q
HOLD1(PAGE,TITL,INST,TEM,TEND) ;
;device is home, reached end of page
S TEND=$G(TEND)
D HOLD^SCRPU3(.PAGE,TITL)
I STOP Q
D HEADER(INST,TEM,TEND)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPSLT2 5967 printed Nov 22, 2024@17:52:53 Page 2
SCRPSLT2 ;ALB/CMM - Summary Listing of Teams Continued ; 9/15/99 10:43am
+1 ;;5.3;Scheduling;**41,174,177,231,520**;AUG 13, 1993;Build 26
+2 ;
+3 ;Summary Listing of Teams Report
+4 ;
KEEP(TNODE,APOS,TPOS,ROL,TM,TPCN,TNPC) ;
+1 ;TNODE - zero node of the team position file
+2 ;APOS - ien of team position file
+3 ;TPOS - ien of position assignment history file
+4 ;ROL - ien of role
+5 ;TM - ien of team
+6 ;
+7 NEW POS,TNAME,TPHONE,TPC,TDIV,TEN,TMN,DIV,PPC,PCLIN,VAE,PRACT,NPC,MAX
+8 NEW PCN,ROLN,PRCTP,PRCPC,PRCNPC,PRCPTE,SCPC,SCNPC,XDAT,SCDT,SCI
+9 ;
+10 ;team file pointer
SET TEN=+$PIECE(TNODE,"^",2)
+11 SET TMN=$GET(^SCTM(404.51,TEN,0))
+12 ;team name
SET TNAME=$PIECE(TMN,"^")
+13 ;division ien
SET DIV=+$PIECE(TMN,"^",7)
+14 ;team division
SET TDIV=$PIECE($GET(^DIC(4,DIV,0)),"^")
+15 DO KTEAM(TNAME,TDIV,TM,DIV)
+16 ;
+17 ;position name
SET POS=$PIECE(TNODE,"^")
+18 ;SD*5.3*231 - call SCMCLK to determine in AP or not
+19 ;PC?
SET PPC=$SELECT($PIECE(TNODE,"^",4)<1:"NPC",+$$OKPREC3^SCMCLK(APOS,DT)>0:" AP",1:"PCP")
+20 ;S PCLIN=$P($G(^SC(+$P(TNODE,"^",9),0)),"^") ;associated clinic
+21 DO SETASCL^SCRPRAC2(APOS,.PCLIN)
+22 SET PCLIN=$GET(PCLIN(0))
+23 ;role name
SET ROLN=$PIECE($GET(^SD(403.46,+ROL,0)),U)
+24 ;
+25 SET (PRCPC,PRCNPC)=""
SET SCI="^TMP(""SCRATCH"",$J)"
+26 KILL @SCI
+27 SET (SCDT("BEGIN"),SCDT("END"))=DT
SET SCDT("INCL")=0
SET SCDT="SCDT"
+28 SET SCI=$$PRECHIS^SCMCLK(APOS,.SCDT,SCI)
+29 IF SCI=1
SET SCI=0
FOR
SET SCI=$ORDER(^TMP("SCRATCH",$JOB,SCI))
if 'SCI
QUIT
Begin DoDot:1
+30 NEW SCPRCD
+31 SET SCPRCD=^TMP("SCRATCH",$JOB,SCI)
SET PRCPTE=$PIECE(SCPRCD,U,3)
if 'PRCPTE
QUIT
+32 ;precepted PC patients
SET SCPC=$$PCPOSCNT^SCAPMCU1(PRCPTE,DT,1)
+33 if SCPC<0
SET SCPC=0
SET PRCPC=PRCPC+SCPC
+34 ;all precepted patients
SET SCNPC=$$PCPOSCNT^SCAPMCU1(PRCPTE,DT,0)
+35 if SCNPC<0
SET SCNPC=0
SET SCNPC=SCNPC-SCPC
if SCNPC<0
SET SCNPC=0
+36 SET PRCNPC=PRCNPC+SCNPC
+37 QUIT
End DoDot:1
+38 ;
+39 ;extra data
SET XDAT=ROLN_U_PRCPC_U_PRCNPC
+40 ;
+41 ;ien of new person file
SET VAE=+$PIECE($GET(^SCTM(404.52,TPOS,0)),"^",3)
+42 ;practitioner name
SET PRACT=$PIECE($GET(^VA(200,VAE,0)),"^")
+43 IF PRACT=""
SET PRACT="[Not Assigned]"
+44 ;
+45 SET MAX=+$PIECE(TNODE,"^",8)
IF MAX<0
SET MAX=0
+46 SET PCN=$$PCPOSCNT^SCAPMCU1(APOS,DT)
if PCN=-1
SET PCN=0
+47 SET TPCN(TM)=$GET(TPCN(TM))+PCN
+48 SET NPC=$$PCPOSCNT^SCAPMCU1(APOS,DT,0)
if NPC=-1
SET NPC=0
+49 SET NPC=NPC-PCN
if NPC<0
SET NPC=0
+50 SET TNPC(TM)=$GET(TNPC(TM))+NPC
+51 ;
+52 DO FORMAT(APOS,POS,PCLIN,VAE,PRACT,PPC,DIV,TM,NPC,MAX,PCN,XDAT)
+53 NEW SCAC
+54 SET SCAC=0
+55 FOR
SET SCAC=$ORDER(PCLIN(SCAC))
if SCAC=""
QUIT
DO FORMATAC(APOS,POS,PCLIN(SCAC),VAE,DIV,TM)
+56 QUIT
+57 ;
TEAMT(TM,TPASS,TMAX,TPCN,TOA,TNPC) ;
+1 ;set team totals into global
+2 SET @STORE@("TOTALS",TM,"H1")=" Team Totals:"
+3 SET @STORE@("TOTALS",TM,"H2")="------------------------------------"
+4 SET @STORE@("TOTALS",TM,"H3")=" Primary Care Assignments: "_$JUSTIFY($GET(TPCN(TM)),6,0)
+5 SET @STORE@("TOTALS",TM,"H4")=" Non-PC Assignments: "_$JUSTIFY($GET(TNPC(TM)),6,0)
+6 SET @STORE@("TOTALS",TM,"H5")=" Unique Patients Assigned: "_$JUSTIFY($GET(TPASS(TM)),6,0)
+7 SET @STORE@("TOTALS",TM,"H6")=" Maximum Patients Allowed: "_$JUSTIFY($GET(TMAX(TM)),6,0)
+8 SET @STORE@("TOTALS",TM,"H7")=" Total Open Assignments: "_$JUSTIFY($GET(TOA(TM)),6,0)
+9 QUIT
+10 ;
FORMAT(APOS,POS,PCLIN,VAE,PRACT,PPC,DIV,TM,NPC,MX,PC,XDAT) ;
+1 ;
+2 NEW TMP
+3 IF PRACT=""
SET PRACT="Bad Data"
+4 SET @STORE@("PN",DIV,TM,PRACT,VAE)=""
+5 ;practitioner name
SET @STORE@(DIV,TM,VAE,APOS)=$EXTRACT(PRACT,1,20)
+6 ;position
SET $EXTRACT(@STORE@(DIV,TM,VAE,APOS),23)=$EXTRACT(POS,1,20)
+7 ;PC?
SET $EXTRACT(@STORE@(DIV,TM,VAE,APOS),45)=PPC
+8 ;role
SET $EXTRACT(@STORE@(DIV,TM,VAE,APOS),50)=$EXTRACT($PIECE(XDAT,U),1,20)
+9 ;assoc. clinic
SET $EXTRACT(@STORE@(DIV,TM,VAE,APOS),72)=$EXTRACT(PCLIN,1,25)
+10 ;max pts.
SET $EXTRACT(@STORE@(DIV,TM,VAE,APOS),99)=$JUSTIFY(MX,6,0)
+11 ;PC pts.
SET $EXTRACT(@STORE@(DIV,TM,VAE,APOS),107)=$JUSTIFY(PC,5,0)
+12 ;non-PC pts.
SET $EXTRACT(@STORE@(DIV,TM,VAE,APOS),114)=$JUSTIFY(NPC,5,0)
+13 ;
+14 ;bp/djb 'Precepted Patients' column should be zero for APs.
+15 ;Old code begins
+16 ;S $E(@STORE@(DIV,TM,VAE,APOS),121)=$J($P(XDAT,U,2),5,0) ;precept PC
+17 ;S $E(@STORE@(DIV,TM,VAE,APOS),128)=$J($P(XDAT,U,3),5,0) ;precept NPC
+18 ;Old code ends
+19 ;New code begins
+20 ;APs should be zero
SET (TMP(1),TMP(2))=0
IF PPC'["AP"
Begin DoDot:1
+21 SET TMP(1)=$PIECE(XDAT,U,2)
+22 SET TMP(2)=$PIECE(XDAT,U,3)
End DoDot:1
+23 ;precepted PC
SET $EXTRACT(@STORE@(DIV,TM,VAE,APOS),121)=$JUSTIFY(TMP(1),5,0)
+24 ;precepted NPC
SET $EXTRACT(@STORE@(DIV,TM,VAE,APOS),128)=$JUSTIFY(TMP(2),5,0)
+25 ;New code ends
+26 QUIT
FORMATAC(APOS,POS,PCLIN,VAE,DIV,TM) ;clinic multiples
+1 SET $EXTRACT(@STORE@(DIV,TM,VAE,APOS,SCAC),72)=$EXTRACT(PCLIN,1,30)
+2 QUIT
+3 ;
TOTAL(INST,TEM) ;
+1 ;Prints team totals
+2 NEW NXT
+3 SET NXT=""
+4 WRITE !
+5 FOR
SET NXT=$ORDER(@STORE@("TOTALS",TEM,NXT))
if NXT=""
QUIT
Begin DoDot:1
+6 ;bp/djb Stop displaying certain 'Team Totals:' lines.
+7 ;New code begin
+8 if $GET(@STORE@("TOTALS",TEM,NXT))["Unique Patients Assigned"
QUIT
+9 if $GET(@STORE@("TOTALS",TEM,NXT))["Maximum Patients Allowed"
QUIT
+10 if $GET(@STORE@("TOTALS",TEM,NXT))["Total Open Assignments"
QUIT
+11 ;New code end
+12 WRITE !,$GET(@STORE@("TOTALS",TEM,NXT))
End DoDot:1
+13 WRITE !
+14 QUIT
+15 ;
KTEAM(TNAME,TDIV,TIEN,IEND) ;
+1 ;store team information
+2 IF TNAME=""
SET TNAME="[BAD DATA]"
+3 IF TDIV=""
SET TDIV="[BAD 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)="Team Name: "_TNAME
+8 QUIT
+9 ;
FORHEAD ;
+1 SET @STORE@("H3")="Practitioner"
+2 SET $EXTRACT(@STORE@("H3"),23)="Position"
+3 SET $EXTRACT(@STORE@("H3"),45)="PC?"
+4 SET $EXTRACT(@STORE@("H3"),50)="Standard Role"
+5 SET $EXTRACT(@STORE@("H3"),72)="Associated Clinic"
+6 SET $EXTRACT(@STORE@("H1"),101)="Max."
+7 SET $EXTRACT(@STORE@("H2"),101)="Pts."
+8 SET $EXTRACT(@STORE@("H3"),99)="Allow."
+9 SET $EXTRACT(@STORE@("H1"),107)="--Assigned--"
+10 SET $EXTRACT(@STORE@("H2"),107)="--Patients--"
+11 SET $EXTRACT(@STORE@("H3"),107)="PC NonPC"
+12 SET $EXTRACT(@STORE@("H1"),121)="--Precepted-"
+13 SET $EXTRACT(@STORE@("H2"),121)="--Patients--"
+14 SET $EXTRACT(@STORE@("H3"),121)="PC NonPC"
+15 SET $PIECE(@STORE@("H4"),"=",133)=""
+16 QUIT
+1 NEW NXT
+2 SET NXT="H"
SET TEND=$GET(TEND)
+3 WRITE !!,@STORE@(INST)
+4 WRITE !!,@STORE@(INST,TEM)
+5 IF 'TEND
FOR
SET NXT=$ORDER(@STORE@(NXT))
if NXT'?1"H".E
QUIT
Begin DoDot:1
+6 WRITE !,@STORE@(NXT)
End DoDot:1
+7 WRITE !
+8 QUIT
NEWP(INST,TEM,TITL,PAGE,TEND) ;
+1 SET TEND=$GET(TEND)
+2 DO NEWP1^SCRPU3(.PAGE,TITL)
+3 IF STOP
QUIT
+4 DO HEADER(INST,TEM,TEND)
+5 QUIT
HOLD1(PAGE,TITL,INST,TEM,TEND) ;
+1 ;device is home, reached end of page
+2 SET TEND=$GET(TEND)
+3 DO HOLD^SCRPU3(.PAGE,TITL)
+4 IF STOP
QUIT
+5 DO HEADER(INST,TEM,TEND)
+6 QUIT
