Changeset 623 for WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPSLT2.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPSLT2.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPSLT2.m
r613 r623 1 SCRPSLT2 ;ALB/CMM - Summary Listing of Teams Continued ; 9/15/99 10:43am 2 ;;5.3;Scheduling;**41,174,177,231,520**;AUG 13, 1993;Build 26 3 ; 4 ;Summary Listing of Teams Report 5 ; 6 KEEP(TNODE,APOS,TPOS,ROL,TM,TPCN,TNPC) ; 7 ;TNODE - zero node of the team position file 8 ;APOS - ien of team position file 9 ;TPOS - ien of position assignment history file 10 ;ROL - ien of role 11 ;TM - ien of team 12 ; 13 N POS,TNAME,TPHONE,TPC,TDIV,TEN,TMN,DIV,PPC,PCLIN,VAE,PRACT,NPC,MAX 14 N PCN,ROLN,PRCTP,PRCPC,PRCNPC,PRCPTE,SCPC,SCNPC,XDAT,SCDT,SCI 15 ; 16 S TEN=+$P(TNODE,"^",2) ;team file pointer 17 S TMN=$G(^SCTM(404.51,TEN,0)) 18 S TNAME=$P(TMN,"^") ;team name 19 S DIV=+$P(TMN,"^",7) ;division ien 20 S TDIV=$P($G(^DIC(4,DIV,0)),"^") ;team division 21 D KTEAM(TNAME,TDIV,TM,DIV) 22 ; 23 S POS=$P(TNODE,"^") ;position name 24 ;SD*5.3*231 - call SCMCLK to determine in AP or not 25 S PPC=$S($P(TNODE,"^",4)<1:"NPC",+$$OKPREC3^SCMCLK(APOS,DT)>0:" AP",1:"PCP") ;PC? 26 ;S PCLIN=$P($G(^SC(+$P(TNODE,"^",9),0)),"^") ;associated clinic 27 D SETASCL^SCRPRAC2(APOS,.PCLIN) 28 S PCLIN=$G(PCLIN(0)) 29 S ROLN=$P($G(^SD(403.46,+ROL,0)),U) ;role name 30 ; 31 S (PRCPC,PRCNPC)="",SCI="^TMP(""SCRATCH"",$J)" 32 K @SCI 33 S (SCDT("BEGIN"),SCDT("END"))=DT,SCDT("INCL")=0,SCDT="SCDT" 34 S SCI=$$PRECHIS^SCMCLK(APOS,.SCDT,SCI) 35 I SCI=1 S SCI=0 F S SCI=$O(^TMP("SCRATCH",$J,SCI)) Q:'SCI D 36 .N SCPRCD 37 .S SCPRCD=^TMP("SCRATCH",$J,SCI),PRCPTE=$P(SCPRCD,U,3) Q:'PRCPTE 38 .S SCPC=$$PCPOSCNT^SCAPMCU1(PRCPTE,DT,1) ;precepted PC patients 39 .S:SCPC<0 SCPC=0 S PRCPC=PRCPC+SCPC 40 .S SCNPC=$$PCPOSCNT^SCAPMCU1(PRCPTE,DT,0) ;all precepted patients 41 .S:SCNPC<0 SCNPC=0 S SCNPC=SCNPC-SCPC S:SCNPC<0 SCNPC=0 42 .S PRCNPC=PRCNPC+SCNPC 43 .Q 44 ; 45 S XDAT=ROLN_U_PRCPC_U_PRCNPC ;extra data 46 ; 47 S VAE=+$P($G(^SCTM(404.52,TPOS,0)),"^",3) ;ien of new person file 48 S PRACT=$P($G(^VA(200,VAE,0)),"^") ;practitioner name 49 I PRACT="" S PRACT="[Not Assigned]" 50 ; 51 S MAX=+$P(TNODE,"^",8) I MAX<0 S MAX=0 52 S PCN=$$PCPOSCNT^SCAPMCU1(APOS,DT) S:PCN=-1 PCN=0 53 S TPCN(TM)=$G(TPCN(TM))+PCN 54 S NPC=$$PCPOSCNT^SCAPMCU1(APOS,DT,0) S:NPC=-1 NPC=0 55 S NPC=NPC-PCN S:NPC<0 NPC=0 56 S TNPC(TM)=$G(TNPC(TM))+NPC 57 ; 58 D FORMAT(APOS,POS,PCLIN,VAE,PRACT,PPC,DIV,TM,NPC,MAX,PCN,XDAT) 59 N SCAC 60 S SCAC=0 61 F S SCAC=$O(PCLIN(SCAC)) Q:SCAC="" D FORMATAC(APOS,POS,PCLIN(SCAC),VAE,DIV,TM) 62 Q 63 ; 64 TEAMT(TM,TPASS,TMAX,TPCN,TOA,TNPC) ; 65 ;set team totals into global 66 S @STORE@("TOTALS",TM,"H1")=" Team Totals:" 67 S @STORE@("TOTALS",TM,"H2")="------------------------------------" 68 S @STORE@("TOTALS",TM,"H3")=" Primary Care Assignments: "_$J($G(TPCN(TM)),6,0) 69 S @STORE@("TOTALS",TM,"H4")=" Non-PC Assignments: "_$J($G(TNPC(TM)),6,0) 70 S @STORE@("TOTALS",TM,"H5")=" Unique Patients Assigned: "_$J($G(TPASS(TM)),6,0) 71 S @STORE@("TOTALS",TM,"H6")=" Maximum Patients Allowed: "_$J($G(TMAX(TM)),6,0) 72 S @STORE@("TOTALS",TM,"H7")=" Total Open Assignments: "_$J($G(TOA(TM)),6,0) 73 Q 74 ; 75 FORMAT(APOS,POS,PCLIN,VAE,PRACT,PPC,DIV,TM,NPC,MX,PC,XDAT) ; 76 ; 77 NEW TMP 78 I PRACT="" S PRACT="Bad Data" 79 S @STORE@("PN",DIV,TM,PRACT,VAE)="" 80 S @STORE@(DIV,TM,VAE,APOS)=$E(PRACT,1,20) ;practitioner name 81 S $E(@STORE@(DIV,TM,VAE,APOS),23)=$E(POS,1,20) ;position 82 S $E(@STORE@(DIV,TM,VAE,APOS),45)=PPC ;PC? 83 S $E(@STORE@(DIV,TM,VAE,APOS),50)=$E($P(XDAT,U),1,20) ;role 84 S $E(@STORE@(DIV,TM,VAE,APOS),72)=$E(PCLIN,1,25) ;assoc. clinic 85 S $E(@STORE@(DIV,TM,VAE,APOS),99)=$J(MX,6,0) ;max pts. 86 S $E(@STORE@(DIV,TM,VAE,APOS),107)=$J(PC,5,0) ;PC pts. 87 S $E(@STORE@(DIV,TM,VAE,APOS),114)=$J(NPC,5,0) ;non-PC pts. 88 ; 89 ;bp/djb 'Precepted Patients' column should be zero for APs. 90 ;Old code begins 91 ;S $E(@STORE@(DIV,TM,VAE,APOS),121)=$J($P(XDAT,U,2),5,0) ;precept PC 92 ;S $E(@STORE@(DIV,TM,VAE,APOS),128)=$J($P(XDAT,U,3),5,0) ;precept NPC 93 ;Old code ends 94 ;New code begins 95 S (TMP(1),TMP(2))=0 I PPC'["AP" D ;APs should be zero 96 .S TMP(1)=$P(XDAT,U,2) 97 .S TMP(2)=$P(XDAT,U,3) 98 S $E(@STORE@(DIV,TM,VAE,APOS),121)=$J(TMP(1),5,0) ;precepted PC 99 S $E(@STORE@(DIV,TM,VAE,APOS),128)=$J(TMP(2),5,0) ;precepted NPC 100 ;New code ends 101 Q 102 FORMATAC(APOS,POS,PCLIN,VAE,DIV,TM) ;clinic multiples 103 S $E(@STORE@(DIV,TM,VAE,APOS,SCAC),72)=$E(PCLIN,1,30) 104 Q 105 ; 106 TOTAL(INST,TEM) ; 107 ;Prints team totals 108 N NXT 109 S NXT="" 110 W ! 111 F S NXT=$O(@STORE@("TOTALS",TEM,NXT)) Q:NXT="" D 112 .;bp/djb Stop displaying certain 'Team Totals:' lines. 113 .;New code begin 114 .Q:$G(@STORE@("TOTALS",TEM,NXT))["Unique Patients Assigned" 115 .Q:$G(@STORE@("TOTALS",TEM,NXT))["Maximum Patients Allowed" 116 .Q:$G(@STORE@("TOTALS",TEM,NXT))["Total Open Assignments" 117 .;New code end 118 .W !,$G(@STORE@("TOTALS",TEM,NXT)) 119 W ! 120 Q 121 ; 122 KTEAM(TNAME,TDIV,TIEN,IEND) ; 123 ;store team information 124 I TNAME="" S TNAME="[BAD DATA]" 125 I TDIV="" S TDIV="[BAD DATA]" 126 S @STORE@("I",TDIV,IEND)="" 127 S @STORE@("T",IEND,TNAME,TIEN)="" 128 S @STORE@(IEND)=" Division: "_TDIV 129 S @STORE@(IEND,TIEN)="Team Name: "_TNAME 130 Q 131 ; 132 FORHEAD ; 133 S @STORE@("H3")="Practitioner" 134 S $E(@STORE@("H3"),23)="Position" 135 S $E(@STORE@("H3"),45)="PC?" 136 S $E(@STORE@("H3"),50)="Standard Role" 137 S $E(@STORE@("H3"),72)="Associated Clinic" 138 S $E(@STORE@("H1"),101)="Max." 139 S $E(@STORE@("H2"),101)="Pts." 140 S $E(@STORE@("H3"),99)="Allow." 141 S $E(@STORE@("H1"),107)="--Assigned--" 142 S $E(@STORE@("H2"),107)="--Patients--" 143 S $E(@STORE@("H3"),107)="PC NonPC" 144 S $E(@STORE@("H1"),121)="--Precepted-" 145 S $E(@STORE@("H2"),121)="--Patients--" 146 S $E(@STORE@("H3"),121)="PC NonPC" 147 S $P(@STORE@("H4"),"=",133)="" 148 Q 149 HEADER(INST,TEM,TEND) ; 150 N NXT 151 S NXT="H",TEND=$G(TEND) 152 W !!,@STORE@(INST) 153 W !!,@STORE@(INST,TEM) 154 I 'TEND F S NXT=$O(@STORE@(NXT)) Q:NXT'?1"H".E D 155 .W !,@STORE@(NXT) 156 W ! 157 Q 158 NEWP(INST,TEM,TITL,PAGE,TEND) ; 159 S TEND=$G(TEND) 160 D NEWP1^SCRPU3(.PAGE,TITL) 161 I STOP Q 162 D HEADER(INST,TEM,TEND) 163 Q 164 HOLD1(PAGE,TITL,INST,TEM,TEND) ; 165 ;device is home, reached end of page 166 S TEND=$G(TEND) 167 D HOLD^SCRPU3(.PAGE,TITL) 168 I STOP Q 169 D HEADER(INST,TEM,TEND) 170 Q 1 SCRPSLT2 ;ALB/CMM - Summary Listing of Teams Continued ; 9/15/99 10:43am 2 ;;5.3;Scheduling;**41,174,177,231**;AUG 13, 1993 3 ; 4 ;Summary Listing of Teams Report 5 ; 6 KEEP(TNODE,APOS,TPOS,ROL,TM,TPCN,TNPC) ; 7 ;TNODE - zero node of the team position file 8 ;APOS - ien of team position file 9 ;TPOS - ien of position assignment history file 10 ;ROL - ien of role 11 ;TM - ien of team 12 ; 13 N POS,TNAME,TPHONE,TPC,TDIV,TEN,TMN,DIV,PPC,PCLIN,VAE,PRACT,NPC,MAX 14 N PCN,ROLN,PRCTP,PRCPC,PRCNPC,PRCPTE,SCPC,SCNPC,XDAT,SCDT,SCI 15 ; 16 S TEN=+$P(TNODE,"^",2) ;team file pointer 17 S TMN=$G(^SCTM(404.51,TEN,0)) 18 S TNAME=$P(TMN,"^") ;team name 19 S DIV=+$P(TMN,"^",7) ;division ien 20 S TDIV=$P($G(^DIC(4,DIV,0)),"^") ;team division 21 D KTEAM(TNAME,TDIV,TM,DIV) 22 ; 23 S POS=$P(TNODE,"^") ;position name 24 ;SD*5.3*231 - call SCMCLK to determine in AP or not 25 S PPC=$S($P(TNODE,"^",4)<1:"NPC",+$$OKPREC3^SCMCLK(APOS,DT)>1:" AP",1:"PCP") ;PC? 26 S PCLIN=$P($G(^SC(+$P(TNODE,"^",9),0)),"^") ;associated clinic 27 S ROLN=$P($G(^SD(403.46,+ROL,0)),U) ;role name 28 ; 29 S (PRCPC,PRCNPC)="",SCI="^TMP(""SCRATCH"",$J)" 30 K @SCI 31 S (SCDT("BEGIN"),SCDT("END"))=DT,SCDT("INCL")=0,SCDT="SCDT" 32 S SCI=$$PRECHIS^SCMCLK(APOS,.SCDT,SCI) 33 I SCI=1 S SCI=0 F S SCI=$O(^TMP("SCRATCH",$J,SCI)) Q:'SCI D 34 .N SCPRCD 35 .S SCPRCD=^TMP("SCRATCH",$J,SCI),PRCPTE=$P(SCPRCD,U,3) Q:'PRCPTE 36 .S SCPC=$$PCPOSCNT^SCAPMCU1(PRCPTE,DT,1) ;precepted PC patients 37 .S:SCPC<0 SCPC=0 S PRCPC=PRCPC+SCPC 38 .S SCNPC=$$PCPOSCNT^SCAPMCU1(PRCPTE,DT,0) ;all precepted patients 39 .S:SCNPC<0 SCNPC=0 S SCNPC=SCNPC-SCPC S:SCNPC<0 SCNPC=0 40 .S PRCNPC=PRCNPC+SCNPC 41 .Q 42 ; 43 S XDAT=ROLN_U_PRCPC_U_PRCNPC ;extra data 44 ; 45 S VAE=+$P($G(^SCTM(404.52,TPOS,0)),"^",3) ;ien of new person file 46 S PRACT=$P($G(^VA(200,VAE,0)),"^") ;practitioner name 47 I PRACT="" S PRACT="[Not Assigned]" 48 ; 49 S MAX=+$P(TNODE,"^",8) I MAX<0 S MAX=0 50 S PCN=$$PCPOSCNT^SCAPMCU1(APOS,DT) S:PCN=-1 PCN=0 51 S TPCN(TM)=$G(TPCN(TM))+PCN 52 S NPC=$$PCPOSCNT^SCAPMCU1(APOS,DT,0) S:NPC=-1 NPC=0 53 S NPC=NPC-PCN S:NPC<0 NPC=0 54 S TNPC(TM)=$G(TNPC(TM))+NPC 55 ; 56 D FORMAT(APOS,POS,PCLIN,VAE,PRACT,PPC,DIV,TM,NPC,MAX,PCN,XDAT) 57 Q 58 ; 59 TEAMT(TM,TPASS,TMAX,TPCN,TOA,TNPC) ; 60 ;set team totals into global 61 S @STORE@("TOTALS",TM,"H1")=" Team Totals:" 62 S @STORE@("TOTALS",TM,"H2")="------------------------------------" 63 S @STORE@("TOTALS",TM,"H3")=" Primary Care Assignments: "_$J($G(TPCN(TM)),6,0) 64 S @STORE@("TOTALS",TM,"H4")=" Non-PC Assignments: "_$J($G(TNPC(TM)),6,0) 65 S @STORE@("TOTALS",TM,"H5")=" Unique Patients Assigned: "_$J($G(TPASS(TM)),6,0) 66 S @STORE@("TOTALS",TM,"H6")=" Maximum Patients Allowed: "_$J($G(TMAX(TM)),6,0) 67 S @STORE@("TOTALS",TM,"H7")=" Total Open Assignments: "_$J($G(TOA(TM)),6,0) 68 Q 69 ; 70 FORMAT(APOS,POS,PCLIN,VAE,PRACT,PPC,DIV,TM,NPC,MX,PC,XDAT) ; 71 ; 72 NEW TMP 73 I PRACT="" S PRACT="Bad Data" 74 S @STORE@("PN",DIV,TM,PRACT,VAE)="" 75 S @STORE@(DIV,TM,VAE,APOS)=$E(PRACT,1,20) ;practitioner name 76 S $E(@STORE@(DIV,TM,VAE,APOS),23)=$E(POS,1,20) ;position 77 S $E(@STORE@(DIV,TM,VAE,APOS),45)=PPC ;PC? 78 S $E(@STORE@(DIV,TM,VAE,APOS),50)=$E($P(XDAT,U),1,20) ;role 79 S $E(@STORE@(DIV,TM,VAE,APOS),72)=$E(PCLIN,1,25) ;assoc. clinic 80 S $E(@STORE@(DIV,TM,VAE,APOS),99)=$J(MX,6,0) ;max pts. 81 S $E(@STORE@(DIV,TM,VAE,APOS),107)=$J(PC,5,0) ;PC pts. 82 S $E(@STORE@(DIV,TM,VAE,APOS),114)=$J(NPC,5,0) ;non-PC pts. 83 ; 84 ;bp/djb 'Precepted Patients' column should be zero for APs. 85 ;Old code begins 86 ;S $E(@STORE@(DIV,TM,VAE,APOS),121)=$J($P(XDAT,U,2),5,0) ;precept PC 87 ;S $E(@STORE@(DIV,TM,VAE,APOS),128)=$J($P(XDAT,U,3),5,0) ;precept NPC 88 ;Old code ends 89 ;New code begins 90 S (TMP(1),TMP(2))=0 I PPC'["AP" D ;APs should be zero 91 .S TMP(1)=$P(XDAT,U,2) 92 .S TMP(2)=$P(XDAT,U,3) 93 S $E(@STORE@(DIV,TM,VAE,APOS),121)=$J(TMP(1),5,0) ;precepted PC 94 S $E(@STORE@(DIV,TM,VAE,APOS),128)=$J(TMP(2),5,0) ;precepted NPC 95 ;New code ends 96 Q 97 ; 98 TOTAL(INST,TEM) ; 99 ;Prints team totals 100 N NXT 101 S NXT="" 102 W ! 103 F S NXT=$O(@STORE@("TOTALS",TEM,NXT)) Q:NXT="" D 104 .;bp/djb Stop displaying certain 'Team Totals:' lines. 105 .;New code begin 106 .Q:$G(@STORE@("TOTALS",TEM,NXT))["Unique Patients Assigned" 107 .Q:$G(@STORE@("TOTALS",TEM,NXT))["Maximum Patients Allowed" 108 .Q:$G(@STORE@("TOTALS",TEM,NXT))["Total Open Assignments" 109 .;New code end 110 .W !,$G(@STORE@("TOTALS",TEM,NXT)) 111 W ! 112 Q 113 ; 114 KTEAM(TNAME,TDIV,TIEN,IEND) ; 115 ;store team information 116 I TNAME="" S TNAME="[BAD DATA]" 117 I TDIV="" S TDIV="[BAD DATA]" 118 S @STORE@("I",TDIV,IEND)="" 119 S @STORE@("T",IEND,TNAME,TIEN)="" 120 S @STORE@(IEND)=" Division: "_TDIV 121 S @STORE@(IEND,TIEN)="Team Name: "_TNAME 122 Q 123 ; 124 FORHEAD ; 125 S @STORE@("H3")="Practitioner" 126 S $E(@STORE@("H3"),23)="Position" 127 S $E(@STORE@("H3"),45)="PC?" 128 S $E(@STORE@("H3"),50)="Standard Role" 129 S $E(@STORE@("H3"),72)="Associated Clinic" 130 S $E(@STORE@("H1"),101)="Max." 131 S $E(@STORE@("H2"),101)="Pts." 132 S $E(@STORE@("H3"),99)="Allow." 133 S $E(@STORE@("H1"),107)="--Assigned--" 134 S $E(@STORE@("H2"),107)="--Patients--" 135 S $E(@STORE@("H3"),107)="PC NonPC" 136 S $E(@STORE@("H1"),121)="--Precepted-" 137 S $E(@STORE@("H2"),121)="--Patients--" 138 S $E(@STORE@("H3"),121)="PC NonPC" 139 S $P(@STORE@("H4"),"=",133)="" 140 Q 141 HEADER(INST,TEM,TEND) ; 142 N NXT 143 S NXT="H",TEND=$G(TEND) 144 W !!,@STORE@(INST) 145 W !!,@STORE@(INST,TEM) 146 I 'TEND F S NXT=$O(@STORE@(NXT)) Q:NXT'?1"H".E D 147 .W !,@STORE@(NXT) 148 W ! 149 Q 150 NEWP(INST,TEM,TITL,PAGE,TEND) ; 151 S TEND=$G(TEND) 152 D NEWP1^SCRPU3(.PAGE,TITL) 153 I STOP Q 154 D HEADER(INST,TEM,TEND) 155 Q 156 HOLD1(PAGE,TITL,INST,TEM,TEND) ; 157 ;device is home, reached end of page 158 S TEND=$G(TEND) 159 D HOLD^SCRPU3(.PAGE,TITL) 160 I STOP Q 161 D HEADER(INST,TEM,TEND) 162 Q
Note:
See TracChangeset
for help on using the changeset viewer.
