- 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 Jan 18, 2025@03:43:51 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