SCRPO4 ;BP-CIOFO/KEITH - Historical Provider Position Assignment Listing (cont.) ; 9/3/99 12:52pm
;;5.3;Scheduling;**177**;AUG 13, 1993
;
BPRPA(SCPASS,SCDIV,SCTEAM,SCPOS,SCLINIC,SCFMT) ;Evaluate provider position assignment information
;Input: SCPASS=provider position assignment information
; string from $$PRTP^SCAPMC
;Input: SCDIV=division^ifn
;Input: SCTEAM=team^ifn
;Input: SCPOS=team position^ifn
;Input: SCLINIC=associated clinic^ifn (if one exists)
;Input: SCFMT=report format (detail or summary)
;
;evaluate assignment/gather data
N SCI,SCTP0,SCPC,SCMAX,SCACT,SCINAC,SCARR,ERR,SCPTD,SCPTPA0,SCX
N DFN,SCPCA,SCNPCA,SCOSL,SCPPC,SCPNPC,SCPPOSD,SCPACT,SCPINAC,SCDT2
N SCPPTD,SCPPTPA0,SCPROV,SCPTP0,SCY
Q:+SCPASS'>0 ;invalid provider ifn
;not a selected provider
I $O(^TMP("SC",$J,"ASPR",0)),'$D(^TMP("SC",$J,"ASPR",+SCPASS)) Q
S SCPROV=$P(SCPASS,U,2)_U_$P(SCPASS,U) ;provider name^ifn
S SCTP0=$G(^SCTM(404.57,+$P(SCPASS,U,3),0)) Q:'$L(SCTP0)
S SCPC=$S($P(SCTP0,U,4)=1:"YES",1:"NO") Q:'$$SPCAT(SCPC) ;pc? y/n
S SCMAX=+$P(SCTP0,U,8) ;maximum patients
;adjust dates if necessary
S SCACT=$P(SCPASS,U,9),SCINAC=$P(SCPASS,U,10)
M SCDT=^TMP("SC",$J,"DTR") S SCDT="SCDT"
I SCACT>SCDT("BEGIN") S SCDT("BEGIN")=SCACT
I SCINAC,SCINAC<SCDT("END") S SCDT("END")=SCINAC
S SCARR="^TMP(""SCARR"",$J,2)" K @SCARR,^TMP("SCARR",$J,3)
S SCI=$$PTTP^SCAPMC($P(SCPOS,U,2),.SCDT,SCARR,"ERR")
;count patients assigned to the provider
S SCI=0 F S SCI=$O(^TMP("SCARR",$J,2,SCI)) Q:'SCI D
.S SCPTD=^TMP("SCARR",$J,2,SCI),DFN=+SCPTD Q:DFN'>0
.S SCPTPA0=$G(^SCPT(404.43,+$P(SCPTD,U,3),0)) Q:'$L(SCPTPA0)
.S SCX=$S($P(SCPTPA0,U,5)>0:"PC",1:"NPC")
.S ^TMP("SCARR",$J,3,SCX,DFN)=""
.Q
S (SCPCA,DFN)=0 F S DFN=$O(^TMP("SCARR",$J,3,"PC",DFN)) Q:'DFN D
.S SCPCA=SCPCA+1
.Q
S (SCNPCA,DFN)=0 F S DFN=$O(^TMP("SCARR",$J,3,"NPC",DFN)) Q:'DFN D
.S SCNPCA=SCNPCA+1
.Q
;jlu added 4 to clean up array 9/8/99
F SCI=2,3,4 K ^TMP("SCARR",$J,SCI)
S SCOSL=SCMAX-SCPCA-SCNPCA S:SCOSL<0 SCOSL=0 ;open slots
;count precepted patients
S (SCPPC,SCPNPC)=0,SCI=$$PRECHIS^SCMCLK($P(SCPOS,U,2),.SCDT,SCARR)
N SCPPOS S SCI=0 F S SCI=$O(^TMP("SCARR",$J,2,SCI)) Q:'SCI D
.S SCPPOSD=^TMP("SCARR",$J,2,SCI),SCPPOS=$P(SCPPOSD,U,3) Q:'SCPPOS
.S SCPACT=$P(SCPPOSD,U,14),SCPINAC=$P(SCPPOSD,U,15)
.Q:'SCPACT S:SCPINAC<1 SCPINAC=9999999
.S SCPPOS(SCPPOS,SCPACT,SCPINAC)=""
.Q
S SCPPOS=0 F S SCPPOS=$O(SCPPOS(SCPPOS)) Q:'SCPPOS D
.S SCPACT=0 F S SCPACT=$O(SCPPOS(SCPPOS,SCPACT)) Q:'SCPACT D
..S SCPINAC=0 F S SCPINAC=$O(SCPPOS(SCPPOS,SCPACT,SCPINAC)) Q:'SCPINAC D
..;adjust dates again
..M SCDT2=SCDT S SCDT2="SCDT2"
..I SCPACT>SCDT2("BEGIN") S SCDT2("BEGIN")=SCPACT
..I SCPINAC<SCDT2("END") S SCDT2("END")=SCINAC
..N SCARR S SCARR="^TMP(""SCARR"",$J,3)" K @SCARR,^TMP("SCARR",$J,4)
..;get patients assigned to precepted position
..S SCI=$$PTTP^SCAPMC(SCPPOS,.SCDT2,SCARR,"ERR")
..S SCI=0 F S SCI=$O(^TMP("SCARR",$J,3,SCI)) Q:'SCI D
...S SCPPTD=^TMP("SCARR",$J,3,SCI) Q:'+SCPPTD
...S SCPPTPA0=$G(^SCPT(404.43,+$P(SCPPTD,U,3),0)) Q:'$L(SCPPTPA0)
...S SCX=$S($P(SCPPTPA0,U,5)>0:"PC",1:"NPC")
...S ^TMP("SCARR",$J,4,SCX,+SCPPTD)=""
...Q
..Q
.Q
;bp/djb Positions that have been precepted should show zero in
; the Precepted Patients column.
;Old code begin
;S (SCPPC,DFN)=0 F S DFN=$O(^TMP("SCARR",$J,4,"PC",DFN)) Q:'DFN D
;.S SCPPC=SCPPC+1
;.Q
;S (SCPNPC,DFN)=0 F S DFN=$O(^TMP("SCARR",$J,4,"NPC",DFN)) Q:'DFN D
;.S SCPNPC=SCPNPC+1
;.Q
;Old code end
;New code begin
S (SCPPC,SCPNPC)=0 ;Initialize to zero.
;Only count DFNs if position hasn't been precepted.
I '$D(^SCTM(404.53,"B",$P(SCPOS,"^",2))) D ;
. S DFN=0
. F S DFN=$O(^TMP("SCARR",$J,4,"PC",DFN)) Q:'DFN S SCPPC=SCPPC+1
. S DFN=0
. F S DFN=$O(^TMP("SCARR",$J,4,"NPC",DFN)) Q:'DFN S SCPNPC=SCPNPC+1
;New code end
;
;set data string
S SCX=$E($P(SCPROV,U),1,19)_U_$E($P(SCPOS,U),1,18)_U_SCPC
S SCX=SCX_U_$E($P(SCTEAM,U),1,19)_U_$E($P(SCLINIC,U),1,17)
S SCX=SCX_U_SCMAX_U_SCPCA_U_SCNPCA_U_SCOSL_U_SCPPC_U_SCPNPC
;Set sort values
I SCFMT="D" F SCI=1:1:5 S SCS=$P($G(^TMP("SC",$J,"SORT",SCI)),U,3) D
.I $L(SCS) S SCY=@SCS S:'$L(SCY) SCY="~~~"
.S:'$L(SCS) SCY="~~~" S SCS(SCI)=SCY
.Q
;Set report detail global
I SCFMT="D" D LSET(.SCS,SCX)
;
;Set report summary global
I SCPC="YES" S ^TMP("SCRPT",$J,0,0,"PC")="",^TMP("SCRPT",$J,0,SCDIV,"PC")="",^TMP("SCRPT",$J,0,SCDIV,1,SCTEAM,"PC")=""
S SCX=$P(SCX,U,6,11) F SCI=1:1:6 D
.S $P(^TMP("SCRPT",$J,0,0),U,SCI)=$P($G(^TMP("SCRPT",$J,0,0)),U,SCI)+$P(SCX,U,SCI)
.S $P(^TMP("SCRPT",$J,0,SCDIV),U,SCI)=$P($G(^TMP("SCRPT",$J,0,SCDIV)),U,SCI)+$P(SCX,U,SCI)
.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)
Q
;
LSET(SCS,SCX) ;Set report line
;Input: SCS=array of sort values
;Input: SCX=data strin
N SCI,SCN,SCL
S SCN=$G(^TMP("SCRPT",$J,1,SCS(1),SCS(2),SCS(3))) I 'SCN D
.S ^TMP("SCRPT",$J,1)=$G(^TMP("SCRPT",$J,1))+1
.S SCN=^TMP("SCRPT",$J,1)
.S ^TMP("SCRPT",$J,1,SCS(1),SCS(2),SCS(3))=SCN
.Q
S ^TMP("SCRPT",$J,2)=$G(^TMP("SCRPT",$J,2))+1
S SCL=^TMP("SCRPT",$J,2)
S ^TMP("SCRPT",$J,2,SCN,SCS(4),SCS(5),SCL)=SCX
Q
;
SPCAT(SCPC) ;selected pc assignment type?
;Input: SCPC= possible primary care? YES/NO
Q:$E(^TMP("SC",$J,"ATYPE"))="B" 1
I $E(SCPC)="N" Q $E(^TMP("SC",$J,"ATYPE"))="N"
I $E(SCPC)="Y" Q $E(^TMP("SC",$J,"ATYPE"))="P"
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPO4 5528 printed Sep 23, 2025@20:19:04 Page 2
SCRPO4 ;BP-CIOFO/KEITH - Historical Provider Position Assignment Listing (cont.) ; 9/3/99 12:52pm
+1 ;;5.3;Scheduling;**177**;AUG 13, 1993
+2 ;
BPRPA(SCPASS,SCDIV,SCTEAM,SCPOS,SCLINIC,SCFMT) ;Evaluate provider position assignment information
+1 ;Input: SCPASS=provider position assignment information
+2 ; string from $$PRTP^SCAPMC
+3 ;Input: SCDIV=division^ifn
+4 ;Input: SCTEAM=team^ifn
+5 ;Input: SCPOS=team position^ifn
+6 ;Input: SCLINIC=associated clinic^ifn (if one exists)
+7 ;Input: SCFMT=report format (detail or summary)
+8 ;
+9 ;evaluate assignment/gather data
+10 NEW SCI,SCTP0,SCPC,SCMAX,SCACT,SCINAC,SCARR,ERR,SCPTD,SCPTPA0,SCX
+11 NEW DFN,SCPCA,SCNPCA,SCOSL,SCPPC,SCPNPC,SCPPOSD,SCPACT,SCPINAC,SCDT2
+12 NEW SCPPTD,SCPPTPA0,SCPROV,SCPTP0,SCY
+13 ;invalid provider ifn
if +SCPASS'>0
QUIT
+14 ;not a selected provider
+15 IF $ORDER(^TMP("SC",$JOB,"ASPR",0))
IF '$DATA(^TMP("SC",$JOB,"ASPR",+SCPASS))
QUIT
+16 ;provider name^ifn
SET SCPROV=$PIECE(SCPASS,U,2)_U_$PIECE(SCPASS,U)
+17 SET SCTP0=$GET(^SCTM(404.57,+$PIECE(SCPASS,U,3),0))
if '$LENGTH(SCTP0)
QUIT
+18 ;pc? y/n
SET SCPC=$SELECT($PIECE(SCTP0,U,4)=1:"YES",1:"NO")
if '$$SPCAT(SCPC)
QUIT
+19 ;maximum patients
SET SCMAX=+$PIECE(SCTP0,U,8)
+20 ;adjust dates if necessary
+21 SET SCACT=$PIECE(SCPASS,U,9)
SET SCINAC=$PIECE(SCPASS,U,10)
+22 MERGE SCDT=^TMP("SC",$JOB,"DTR")
SET SCDT="SCDT"
+23 IF SCACT>SCDT("BEGIN")
SET SCDT("BEGIN")=SCACT
+24 IF SCINAC
IF SCINAC<SCDT("END")
SET SCDT("END")=SCINAC
+25 SET SCARR="^TMP(""SCARR"",$J,2)"
KILL @SCARR,^TMP("SCARR",$JOB,3)
+26 SET SCI=$$PTTP^SCAPMC($PIECE(SCPOS,U,2),.SCDT,SCARR,"ERR")
+27 ;count patients assigned to the provider
+28 SET SCI=0
FOR
SET SCI=$ORDER(^TMP("SCARR",$JOB,2,SCI))
if 'SCI
QUIT
Begin DoDot:1
+29 SET SCPTD=^TMP("SCARR",$JOB,2,SCI)
SET DFN=+SCPTD
if DFN'>0
QUIT
+30 SET SCPTPA0=$GET(^SCPT(404.43,+$PIECE(SCPTD,U,3),0))
if '$LENGTH(SCPTPA0)
QUIT
+31 SET SCX=$SELECT($PIECE(SCPTPA0,U,5)>0:"PC",1:"NPC")
+32 SET ^TMP("SCARR",$JOB,3,SCX,DFN)=""
+33 QUIT
End DoDot:1
+34 SET (SCPCA,DFN)=0
FOR
SET DFN=$ORDER(^TMP("SCARR",$JOB,3,"PC",DFN))
if 'DFN
QUIT
Begin DoDot:1
+35 SET SCPCA=SCPCA+1
+36 QUIT
End DoDot:1
+37 SET (SCNPCA,DFN)=0
FOR
SET DFN=$ORDER(^TMP("SCARR",$JOB,3,"NPC",DFN))
if 'DFN
QUIT
Begin DoDot:1
+38 SET SCNPCA=SCNPCA+1
+39 QUIT
End DoDot:1
+40 ;jlu added 4 to clean up array 9/8/99
+41 FOR SCI=2,3,4
KILL ^TMP("SCARR",$JOB,SCI)
+42 ;open slots
SET SCOSL=SCMAX-SCPCA-SCNPCA
if SCOSL<0
SET SCOSL=0
+43 ;count precepted patients
+44 SET (SCPPC,SCPNPC)=0
SET SCI=$$PRECHIS^SCMCLK($PIECE(SCPOS,U,2),.SCDT,SCARR)
+45 NEW SCPPOS
SET SCI=0
FOR
SET SCI=$ORDER(^TMP("SCARR",$JOB,2,SCI))
if 'SCI
QUIT
Begin DoDot:1
+46 SET SCPPOSD=^TMP("SCARR",$JOB,2,SCI)
SET SCPPOS=$PIECE(SCPPOSD,U,3)
if 'SCPPOS
QUIT
+47 SET SCPACT=$PIECE(SCPPOSD,U,14)
SET SCPINAC=$PIECE(SCPPOSD,U,15)
+48 if 'SCPACT
QUIT
if SCPINAC<1
SET SCPINAC=9999999
+49 SET SCPPOS(SCPPOS,SCPACT,SCPINAC)=""
+50 QUIT
End DoDot:1
+51 SET SCPPOS=0
FOR
SET SCPPOS=$ORDER(SCPPOS(SCPPOS))
if 'SCPPOS
QUIT
Begin DoDot:1
+52 SET SCPACT=0
FOR
SET SCPACT=$ORDER(SCPPOS(SCPPOS,SCPACT))
if 'SCPACT
QUIT
Begin DoDot:2
+53 SET SCPINAC=0
FOR
SET SCPINAC=$ORDER(SCPPOS(SCPPOS,SCPACT,SCPINAC))
if 'SCPINAC
QUIT
Begin DoDot:3
End DoDot:3
+54 ;adjust dates again
+55 MERGE SCDT2=SCDT
SET SCDT2="SCDT2"
+56 IF SCPACT>SCDT2("BEGIN")
SET SCDT2("BEGIN")=SCPACT
+57 IF SCPINAC<SCDT2("END")
SET SCDT2("END")=SCINAC
+58 NEW SCARR
SET SCARR="^TMP(""SCARR"",$J,3)"
KILL @SCARR,^TMP("SCARR",$JOB,4)
+59 ;get patients assigned to precepted position
+60 SET SCI=$$PTTP^SCAPMC(SCPPOS,.SCDT2,SCARR,"ERR")
+61 SET SCI=0
FOR
SET SCI=$ORDER(^TMP("SCARR",$JOB,3,SCI))
if 'SCI
QUIT
Begin DoDot:3
+62 SET SCPPTD=^TMP("SCARR",$JOB,3,SCI)
if '+SCPPTD
QUIT
+63 SET SCPPTPA0=$GET(^SCPT(404.43,+$PIECE(SCPPTD,U,3),0))
if '$LENGTH(SCPPTPA0)
QUIT
+64 SET SCX=$SELECT($PIECE(SCPPTPA0,U,5)>0:"PC",1:"NPC")
+65 SET ^TMP("SCARR",$JOB,4,SCX,+SCPPTD)=""
+66 QUIT
End DoDot:3
+67 QUIT
End DoDot:2
+68 QUIT
End DoDot:1
+69 ;bp/djb Positions that have been precepted should show zero in
+70 ; the Precepted Patients column.
+71 ;Old code begin
+72 ;S (SCPPC,DFN)=0 F S DFN=$O(^TMP("SCARR",$J,4,"PC",DFN)) Q:'DFN D
+73 ;.S SCPPC=SCPPC+1
+74 ;.Q
+75 ;S (SCPNPC,DFN)=0 F S DFN=$O(^TMP("SCARR",$J,4,"NPC",DFN)) Q:'DFN D
+76 ;.S SCPNPC=SCPNPC+1
+77 ;.Q
+78 ;Old code end
+79 ;New code begin
+80 ;Initialize to zero.
SET (SCPPC,SCPNPC)=0
+81 ;Only count DFNs if position hasn't been precepted.
+82 ;
IF '$DATA(^SCTM(404.53,"B",$PIECE(SCPOS,"^",2)))
Begin DoDot:1
+83 SET DFN=0
+84 FOR
SET DFN=$ORDER(^TMP("SCARR",$JOB,4,"PC",DFN))
if 'DFN
QUIT
SET SCPPC=SCPPC+1
+85 SET DFN=0
+86 FOR
SET DFN=$ORDER(^TMP("SCARR",$JOB,4,"NPC",DFN))
if 'DFN
QUIT
SET SCPNPC=SCPNPC+1
End DoDot:1
+87 ;New code end
+88 ;
+89 ;set data string
+90 SET SCX=$EXTRACT($PIECE(SCPROV,U),1,19)_U_$EXTRACT($PIECE(SCPOS,U),1,18)_U_SCPC
+91 SET SCX=SCX_U_$EXTRACT($PIECE(SCTEAM,U),1,19)_U_$EXTRACT($PIECE(SCLINIC,U),1,17)
+92 SET SCX=SCX_U_SCMAX_U_SCPCA_U_SCNPCA_U_SCOSL_U_SCPPC_U_SCPNPC
+93 ;Set sort values
+94 IF SCFMT="D"
FOR SCI=1:1:5
SET SCS=$PIECE($GET(^TMP("SC",$JOB,"SORT",SCI)),U,3)
Begin DoDot:1
+95 IF $LENGTH(SCS)
SET SCY=@SCS
if '$LENGTH(SCY)
SET SCY="~~~"
+96 if '$LENGTH(SCS)
SET SCY="~~~"
SET SCS(SCI)=SCY
+97 QUIT
End DoDot:1
+98 ;Set report detail global
+99 IF SCFMT="D"
DO LSET(.SCS,SCX)
+100 ;
+101 ;Set report summary global
+102 IF SCPC="YES"
SET ^TMP("SCRPT",$JOB,0,0,"PC")=""
SET ^TMP("SCRPT",$JOB,0,SCDIV,"PC")=""
SET ^TMP("SCRPT",$JOB,0,SCDIV,1,SCTEAM,"PC")=""
+103 SET SCX=$PIECE(SCX,U,6,11)
FOR SCI=1:1:6
Begin DoDot:1
+104 SET $PIECE(^TMP("SCRPT",$JOB,0,0),U,SCI)=$PIECE($GET(^TMP("SCRPT",$JOB,0,0)),U,SCI)+$PIECE(SCX,U,SCI)
+105 SET $PIECE(^TMP("SCRPT",$JOB,0,SCDIV),U,SCI)=$PIECE($GET(^TMP("SCRPT",$JOB,0,SCDIV)),U,SCI)+$PIECE(SCX,U,SCI)
+106 SET $PIECE(^TMP("SCRPT",$JOB,0,SCDIV,1,SCTEAM),U,SCI)=$PIECE($GET(^TMP("SCRPT",$JOB,0,SCDIV,1,SCTEAM)),U,SCI)+$PIECE(SCX,U,SCI)
End DoDot:1
+107 QUIT
+108 ;
LSET(SCS,SCX) ;Set report line
+1 ;Input: SCS=array of sort values
+2 ;Input: SCX=data strin
+3 NEW SCI,SCN,SCL
+4 SET SCN=$GET(^TMP("SCRPT",$JOB,1,SCS(1),SCS(2),SCS(3)))
IF 'SCN
Begin DoDot:1
+5 SET ^TMP("SCRPT",$JOB,1)=$GET(^TMP("SCRPT",$JOB,1))+1
+6 SET SCN=^TMP("SCRPT",$JOB,1)
+7 SET ^TMP("SCRPT",$JOB,1,SCS(1),SCS(2),SCS(3))=SCN
+8 QUIT
End DoDot:1
+9 SET ^TMP("SCRPT",$JOB,2)=$GET(^TMP("SCRPT",$JOB,2))+1
+10 SET SCL=^TMP("SCRPT",$JOB,2)
+11 SET ^TMP("SCRPT",$JOB,2,SCN,SCS(4),SCS(5),SCL)=SCX
+12 QUIT
+13 ;
SPCAT(SCPC) ;selected pc assignment type?
+1 ;Input: SCPC= possible primary care? YES/NO
+2 if $EXTRACT(^TMP("SC",$JOB,"ATYPE"))="B"
QUIT 1
+3 IF $EXTRACT(SCPC)="N"
QUIT $EXTRACT(^TMP("SC",$JOB,"ATYPE"))="N"
+4 IF $EXTRACT(SCPC)="Y"
QUIT $EXTRACT(^TMP("SC",$JOB,"ATYPE"))="P"
+5 QUIT 0
