Routine: SCRPSLT2

SCRPSLT2 ;ALB/CMM - Summary Listing of Teams Continued ; 9/15/99 10:43am

 ;;5.3;Scheduling;**41,174,177,231,520,1015**;AUG 13, 1993;Build 21

 ;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)

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)

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

FORMATAC(APOS,POS,PCLIN,VAE,DIV,TM) ;clinic multiples

 S $E(@STORE@(DIV,TM,VAE,APOS,SCAC),72)=$E(PCLIN,1,30)

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 !

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

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)=""

HEADER(INST,TEM,TEND) ;

 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 !

NEWP(INST,TEM,TITL,PAGE,TEND) ;

 S TEND=$G(TEND)

 D NEWP1^SCRPU3(.PAGE,TITL)

 I STOP Q

 D HEADER(INST,TEM,TEND)

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)

SCRPSLT2  ;ALB/CMM - Summary Listing of Teams Continued ; 9/15/99 10:43am

 +1       ;;5.3;Scheduling;**41,174,177,231,520,1015**;AUG 13, 1993;Build 21

 +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

HEADER(INST,TEM,TEND) ;

 +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

SCRPSLT2.m