source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPO4.m@ 1767

Last change on this file since 1767 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 5.3 KB
Line 
1SCRPO4 ;BP-CIOFO/KEITH - Historical Provider Position Assignment Listing (cont.) ; 9/3/99 12:52pm
2 ;;5.3;Scheduling;**177**;AUG 13, 1993
3 ;
4BPRPA(SCPASS,SCDIV,SCTEAM,SCPOS,SCLINIC,SCFMT) ;Evaluate provider position assignment information
5 ;Input: SCPASS=provider position assignment information
6 ; string from $$PRTP^SCAPMC
7 ;Input: SCDIV=division^ifn
8 ;Input: SCTEAM=team^ifn
9 ;Input: SCPOS=team position^ifn
10 ;Input: SCLINIC=associated clinic^ifn (if one exists)
11 ;Input: SCFMT=report format (detail or summary)
12 ;
13 ;evaluate assignment/gather data
14 N SCI,SCTP0,SCPC,SCMAX,SCACT,SCINAC,SCARR,ERR,SCPTD,SCPTPA0,SCX
15 N DFN,SCPCA,SCNPCA,SCOSL,SCPPC,SCPNPC,SCPPOSD,SCPACT,SCPINAC,SCDT2
16 N SCPPTD,SCPPTPA0,SCPROV,SCPTP0,SCY
17 Q:+SCPASS'>0 ;invalid provider ifn
18 ;not a selected provider
19 I $O(^TMP("SC",$J,"ASPR",0)),'$D(^TMP("SC",$J,"ASPR",+SCPASS)) Q
20 S SCPROV=$P(SCPASS,U,2)_U_$P(SCPASS,U) ;provider name^ifn
21 S SCTP0=$G(^SCTM(404.57,+$P(SCPASS,U,3),0)) Q:'$L(SCTP0)
22 S SCPC=$S($P(SCTP0,U,4)=1:"YES",1:"NO") Q:'$$SPCAT(SCPC) ;pc? y/n
23 S SCMAX=+$P(SCTP0,U,8) ;maximum patients
24 ;adjust dates if necessary
25 S SCACT=$P(SCPASS,U,9),SCINAC=$P(SCPASS,U,10)
26 M SCDT=^TMP("SC",$J,"DTR") S SCDT="SCDT"
27 I SCACT>SCDT("BEGIN") S SCDT("BEGIN")=SCACT
28 I SCINAC,SCINAC<SCDT("END") S SCDT("END")=SCINAC
29 S SCARR="^TMP(""SCARR"",$J,2)" K @SCARR,^TMP("SCARR",$J,3)
30 S SCI=$$PTTP^SCAPMC($P(SCPOS,U,2),.SCDT,SCARR,"ERR")
31 ;count patients assigned to the provider
32 S SCI=0 F S SCI=$O(^TMP("SCARR",$J,2,SCI)) Q:'SCI D
33 .S SCPTD=^TMP("SCARR",$J,2,SCI),DFN=+SCPTD Q:DFN'>0
34 .S SCPTPA0=$G(^SCPT(404.43,+$P(SCPTD,U,3),0)) Q:'$L(SCPTPA0)
35 .S SCX=$S($P(SCPTPA0,U,5)>0:"PC",1:"NPC")
36 .S ^TMP("SCARR",$J,3,SCX,DFN)=""
37 .Q
38 S (SCPCA,DFN)=0 F S DFN=$O(^TMP("SCARR",$J,3,"PC",DFN)) Q:'DFN D
39 .S SCPCA=SCPCA+1
40 .Q
41 S (SCNPCA,DFN)=0 F S DFN=$O(^TMP("SCARR",$J,3,"NPC",DFN)) Q:'DFN D
42 .S SCNPCA=SCNPCA+1
43 .Q
44 ;jlu added 4 to clean up array 9/8/99
45 F SCI=2,3,4 K ^TMP("SCARR",$J,SCI)
46 S SCOSL=SCMAX-SCPCA-SCNPCA S:SCOSL<0 SCOSL=0 ;open slots
47 ;count precepted patients
48 S (SCPPC,SCPNPC)=0,SCI=$$PRECHIS^SCMCLK($P(SCPOS,U,2),.SCDT,SCARR)
49 N SCPPOS S SCI=0 F S SCI=$O(^TMP("SCARR",$J,2,SCI)) Q:'SCI D
50 .S SCPPOSD=^TMP("SCARR",$J,2,SCI),SCPPOS=$P(SCPPOSD,U,3) Q:'SCPPOS
51 .S SCPACT=$P(SCPPOSD,U,14),SCPINAC=$P(SCPPOSD,U,15)
52 .Q:'SCPACT S:SCPINAC<1 SCPINAC=9999999
53 .S SCPPOS(SCPPOS,SCPACT,SCPINAC)=""
54 .Q
55 S SCPPOS=0 F S SCPPOS=$O(SCPPOS(SCPPOS)) Q:'SCPPOS D
56 .S SCPACT=0 F S SCPACT=$O(SCPPOS(SCPPOS,SCPACT)) Q:'SCPACT D
57 ..S SCPINAC=0 F S SCPINAC=$O(SCPPOS(SCPPOS,SCPACT,SCPINAC)) Q:'SCPINAC D
58 ..;adjust dates again
59 ..M SCDT2=SCDT S SCDT2="SCDT2"
60 ..I SCPACT>SCDT2("BEGIN") S SCDT2("BEGIN")=SCPACT
61 ..I SCPINAC<SCDT2("END") S SCDT2("END")=SCINAC
62 ..N SCARR S SCARR="^TMP(""SCARR"",$J,3)" K @SCARR,^TMP("SCARR",$J,4)
63 ..;get patients assigned to precepted position
64 ..S SCI=$$PTTP^SCAPMC(SCPPOS,.SCDT2,SCARR,"ERR")
65 ..S SCI=0 F S SCI=$O(^TMP("SCARR",$J,3,SCI)) Q:'SCI D
66 ...S SCPPTD=^TMP("SCARR",$J,3,SCI) Q:'+SCPPTD
67 ...S SCPPTPA0=$G(^SCPT(404.43,+$P(SCPPTD,U,3),0)) Q:'$L(SCPPTPA0)
68 ...S SCX=$S($P(SCPPTPA0,U,5)>0:"PC",1:"NPC")
69 ...S ^TMP("SCARR",$J,4,SCX,+SCPPTD)=""
70 ...Q
71 ..Q
72 .Q
73 ;bp/djb Positions that have been precepted should show zero in
74 ; the Precepted Patients column.
75 ;Old code begin
76 ;S (SCPPC,DFN)=0 F S DFN=$O(^TMP("SCARR",$J,4,"PC",DFN)) Q:'DFN D
77 ;.S SCPPC=SCPPC+1
78 ;.Q
79 ;S (SCPNPC,DFN)=0 F S DFN=$O(^TMP("SCARR",$J,4,"NPC",DFN)) Q:'DFN D
80 ;.S SCPNPC=SCPNPC+1
81 ;.Q
82 ;Old code end
83 ;New code begin
84 S (SCPPC,SCPNPC)=0 ;Initialize to zero.
85 ;Only count DFNs if position hasn't been precepted.
86 I '$D(^SCTM(404.53,"B",$P(SCPOS,"^",2))) D ;
87 . S DFN=0
88 . F S DFN=$O(^TMP("SCARR",$J,4,"PC",DFN)) Q:'DFN S SCPPC=SCPPC+1
89 . S DFN=0
90 . F S DFN=$O(^TMP("SCARR",$J,4,"NPC",DFN)) Q:'DFN S SCPNPC=SCPNPC+1
91 ;New code end
92 ;
93 ;set data string
94 S SCX=$E($P(SCPROV,U),1,19)_U_$E($P(SCPOS,U),1,18)_U_SCPC
95 S SCX=SCX_U_$E($P(SCTEAM,U),1,19)_U_$E($P(SCLINIC,U),1,17)
96 S SCX=SCX_U_SCMAX_U_SCPCA_U_SCNPCA_U_SCOSL_U_SCPPC_U_SCPNPC
97 ;Set sort values
98 I SCFMT="D" F SCI=1:1:5 S SCS=$P($G(^TMP("SC",$J,"SORT",SCI)),U,3) D
99 .I $L(SCS) S SCY=@SCS S:'$L(SCY) SCY="~~~"
100 .S:'$L(SCS) SCY="~~~" S SCS(SCI)=SCY
101 .Q
102 ;Set report detail global
103 I SCFMT="D" D LSET(.SCS,SCX)
104 ;
105 ;Set report summary global
106 I SCPC="YES" S ^TMP("SCRPT",$J,0,0,"PC")="",^TMP("SCRPT",$J,0,SCDIV,"PC")="",^TMP("SCRPT",$J,0,SCDIV,1,SCTEAM,"PC")=""
107 S SCX=$P(SCX,U,6,11) F SCI=1:1:6 D
108 .S $P(^TMP("SCRPT",$J,0,0),U,SCI)=$P($G(^TMP("SCRPT",$J,0,0)),U,SCI)+$P(SCX,U,SCI)
109 .S $P(^TMP("SCRPT",$J,0,SCDIV),U,SCI)=$P($G(^TMP("SCRPT",$J,0,SCDIV)),U,SCI)+$P(SCX,U,SCI)
110 .S $P(^TMP("SCRPT",$J,0,SCDIV,1,SCTEAM),U,SCI)=$P($G(^TMP("SCRPT",$J,0,SCDIV,1,SCTEAM)),U,SCI)+$P(SCX,U,SCI)
111 Q
112 ;
113LSET(SCS,SCX) ;Set report line
114 ;Input: SCS=array of sort values
115 ;Input: SCX=data strin
116 N SCI,SCN,SCL
117 S SCN=$G(^TMP("SCRPT",$J,1,SCS(1),SCS(2),SCS(3))) I 'SCN D
118 .S ^TMP("SCRPT",$J,1)=$G(^TMP("SCRPT",$J,1))+1
119 .S SCN=^TMP("SCRPT",$J,1)
120 .S ^TMP("SCRPT",$J,1,SCS(1),SCS(2),SCS(3))=SCN
121 .Q
122 S ^TMP("SCRPT",$J,2)=$G(^TMP("SCRPT",$J,2))+1
123 S SCL=^TMP("SCRPT",$J,2)
124 S ^TMP("SCRPT",$J,2,SCN,SCS(4),SCS(5),SCL)=SCX
125 Q
126 ;
127SPCAT(SCPC) ;selected pc assignment type?
128 ;Input: SCPC= possible primary care? YES/NO
129 Q:$E(^TMP("SC",$J,"ATYPE"))="B" 1
130 I $E(SCPC)="N" Q $E(^TMP("SC",$J,"ATYPE"))="N"
131 I $E(SCPC)="Y" Q $E(^TMP("SC",$J,"ATYPE"))="P"
132 Q 0
Note: See TracBrowser for help on using the repository browser.