SCRPO2 ;BP-CIOFO/KEITH - Historical Patient Position Assignment Listing (cont.) ;7/31/99 22:36
;;5.3;Scheduling;**177,1015**;AUG 13, 1993;Build 21
;IHS/ANMC/LJF 11/02/2000 changed SSN to HRCN
; replaced elig/means test with gender/age
;
BPTPA(SCPASS,SCDIV,SCTEAM,SCPOS,SCLINIC,SCFMT) ;Evaluate patient team position assignment information
;Input: SCPASS=patient team position assignment information
; string from $$PTTP^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 SCPTPA,SCPTPA0,SCPC,DFN,SCPT0,SCACT,SCINACT,SCDT,SCPROV,SCX,SDOE0
N SCS,SCI,SCY,SCATY,SCAGE,SCARR,SCENRP,SCGEND,SCLAPP,SCMTST,SCNAPP
N SCPAT,SCPELIG,SCPTYP,SCSSN,ERR
S SCPTPA=$P(SCPASS,U,3) Q:SCPTPA<1 ;patient team position assignment
S SCPTPA0=$G(^SCPT(404.43,+SCPTPA,0)) Q:'$L(SCPTPA0)
S SCACT=$P(SCPTPA0,U,3),SCINACT=$P(SCPTPA0,U,4) ;activation dates
;adjust dates if necessary
S:SCACT<^TMP("SC",$J,"DTR","BEGIN") SCACT=$P(^TMP("SC",$J,"DTR","BEGIN"),U)
I 'SCINACT!(SCINACT>^TMP("SC",$J,"DTR","END")) S SCINACT=$P(^TMP("SC",$J,"DTR","END"),U)
S SCPC=$P(SCPTPA0,U,5) Q:'$$PCROLE(.SCPC) ;pc role?
I $O(^TMP("SC",$J,"PCP",0)),SCPC="NO" Q ;no pc providers here
S DFN=$P(SCPASS,U),SCPT0=$G(^DPT(+DFN,0)) Q:'$L(SCPT0) ;patient node
Q:'$$PTCL(DFN,.SCLINIC,SCACT,SCINACT) ;enrolled clinic
S SCDT("BEGIN")=SCACT,SCDT("END")=SCINACT,SCDT("INCL")=0,SCDT="SCDT"
S SCARR="^TMP(""SCARR"",$J,2)" K @SCARR
S SCI=$$PRTPC^SCAPMC($P(SCPOS,U,2),.SCDT,SCARR,"ERR",1,1)
Q:'$$PROV(.SCPROV,SCPC) ;providers
S SCPAT=$P(SCPT0,U)_U_DFN ;patient name^dfn
S SCSSN=$P(SCPT0,U,9) ;patient ssn
S SCSSN=$$HRCN^BDGF2(DFN,+$G(DUZ(2))) ;IHS/ANMC/LJF 11/2/2000
S SCGEND=$S($P(SCPT0,U,2)="M":"MALE",1:"FEMALE") ;patient gender
S SCAGE=$$AGEGR($P(SCPT0,U,3)) ;patient age group
S SCPELIG=$$ELIG^SCRPO(DFN) ;primary eligibility
S SCMTST=$P($$LST^DGMTU(DFN,SCINACT),U,3,4) ;mt status
S:'$L(SCMTST) SCMTST="(not applicable)^"
K SCX S SDOE0=$P(^TMP("SC",$J,"DTR","END"),U)_U_DFN
D ENEP^SCRPW24(.SCX,"H") S SCENRP=$P(SCX(1),U,2) ;enrollment priority
;
;Set data string
;S SCX=$E($P(SCPAT,U),1,18)_U_$E(SCSSN,6,10) ;IHS/ANMC/LJF 11/2/2000
S SCX=$E($P(SCPAT,U),1,18)_U_SCSSN ;IHS/ANMC/LJF 11/2/2000
;S SCX=SCX_U_$P(SCPELIG,U,2)_U_$P(SCMTST,U,2) ;IHS/ANMC/LJF 11/2/2000
S SCX=SCX_U_$E($P(SCTEAM,U),1,13)_U_U_$E($P(SCPOS,U),1,14)_U
S SCX=SCX_U_$E($P(SCLINIC,U),1,14)
;
;Set line for each provider
S SCN=0 F S SCN=$O(SCPROV(SCN)) Q:'SCN D
.S SCPROV=$P(SCPROV(SCN),U,1,2),SCPTYP=$P(SCPROV(SCN),U,3)
.S SCATY=$S($P(SCPROV(SCN),U,4)="P":"PRECEPTOR PROVIDER",1:"ASSIGNED PROVIDER")
.S $P(SCX,U,6)=$E($P(SCPROV,U),1,14),$P(SCX,U,8)=SCPTYP
.S $P(SCX,U,10)=$P(SCPROV(SCN),U,5,6)
.;
.;Set sort values
.I SCFMT="D" F SCI=1:1:6 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 statistics nodes
.S ^TMP("SCRPT",$J,0,SCATY,SCPROV)=$G(^TMP("SCRPT",$J,0,SCATY,SCPROV))+1
I $L(SCPELIG) S ^TMP("SCRPT",$J,0,"PRIMARY ELIGIBILITY",SCPELIG)=$G(^TMP("SCRPT",$J,0,"PRIMARY ELIGIBILITY",SCPELIG))+1
I $L(SCMTST) S ^TMP("SCRPT",$J,0,"MEANS TEST CATEGORY",SCMTST)=$G(^TMP("SCRPT",$J,0,"MEANS TEST CATEGORY",SCMTST))+1
S ^TMP("SCRPT",$J,0,"GENDER",SCGEND)=$G(^TMP("SCRPT",$J,0,"GENDER",SCGEND))+1
S ^TMP("SCRPT",$J,0,"AGE GROUP",SCAGE)=$G(^TMP("SCRPT",$J,0,"AGE GROUP",SCAGE))+1
S ^TMP("SCRPT",$J,0,"NATIONAL ENROLLMENT PRIORITY",SCENRP)=$G(^TMP("SCRPT",$J,0,"NATIONAL ENROLLMENT PRIORITY",SCENRP))+1
S ^TMP("SCRPT",$J,0,"TEAM",SCTEAM)=$G(^TMP("SCRPT",$J,0,"TEAM",SCTEAM))+1
S ^TMP("SCRPT",$J,0,"PRIMARY CARE",SCPC)=$G(^TMP("SCRPT",$J,0,"PRIMARY CARE",SCPC))+1
S ^TMP("SCRPT",$J,0,"DIVISION",SCDIV)=$G(^TMP("SCRPT",$J,0,"DIVISION",SCDIV))+1
S ^TMP("SCRPT",$J,0,"ASSIGNMENTS")=$G(^TMP("SCRPT",$J,0,"ASSIGNMENTS"))+1
S ^TMP("SCRPT",$J,0,"UNIQUES",DFN)=""
Q
;
LSET(SCS,SCX) ;Set report line
;Input: SCS=array of sort values
;Input: SCX=data string
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),SCS(6),SCL)=SCX
Q
;
PROV(SCPROV,SCPC) ;evaluate providers
;Input: SCPROV=variable to return array of provider^ifn^type
;Input: SCPC=pc? yes/no
;Output: '1' if successful, '0' otherwise
;
N SCI,SCPCF,SCFOUND,SCFPC,SCFAS,SCPRD,SCN,SCSUB,SCLEV,SCR,SCPP
S SCFPC=$O(^TMP("SC",$J,"PCP",0))>0 ;find pc provider flag
S SCFAS=$O(^TMP("SC",$J,"ASPR",0))>0 ;find assigned provider flag
S SCPCF=$S(SCPC="NO":0,$D(^TMP("SCARR",$J,2,"PPROV")):2,1:1),SCN=0
S SCFOUND=$S(SCFPC!SCFAS:0,1:1) ;success indicator
S SCPP=0,SCR="" F S SCR=$O(^TMP("SCARR",$J,2,SCR)) Q:'SCR!SCPP D
.S:$D(^TMP("SCARR",$J,2,SCR,"PREC")) SCPP=1
.Q ;Preceptor position flag
I SCFAS D ;Find selected assigned providers
.S SCR=""
.F S SCI=$O(^TMP("SCARR",$J,2,SCR)) Q:SCR="" D
..S SCI=""
..F S SCI=$O(^TMP("SCARR",$J,2,SCR,"PROV-P",SCI)) Q:SCI="" D
...S SCPRD=^TMP("SCARR",$J,2,SCR,"PROV-P",SCI)
...I $D(^TMP("SC",$J,"ASPR",+SCPRD)) D PSET(SCPRD,SCPC,1,.SCN,"A",SCPP) S SCFOUND=1
...Q
..Q
.S SCR=""
.F S SCI=$O(^TMP("SCARR",$J,2,SCR)) Q:SCR="" D
..S SCI=""
..F S SCI=$O(^TMP("SCARR",$J,2,SCR,"PROV-U",SCI)) Q:SCI="" D
...S SCPRD=^TMP("SCARR",$J,2,SCR,"PROV-U",SCI)
...I $D(^TMP("SC",$J,"ASPR",+SCPRD)) D PSET(SCPRD,SCPC,1,.SCN,"A",0) S SCFOUND=1
...Q
..Q
.Q
I SCFPC,'SCPP D ;Find selected pc providers in top level
.S SCR=""
.F S SCI=$O(^TMP("SCARR",$J,2,SCR)) Q:SCR="" D
..S SCI=""
..F S SCI=$O(^TMP("SCARR",$J,2,SCR,"PROV-U",SCI)) Q:SCI="" D
...S SCPRD=^TMP("SCARR",$J,2,SCR,"PROV-U",SCI)
...I $D(^TMP("SC",$J,"PCP",+SCPRD)) D PSET(SCPRD,SCPC,1,.SCN,"A",SCPP) S SCFOUND=1
...Q
..Q
.Q
I SCFPC,SCPP D ;Find selected pc providers in preceptor level
.S SCR=""
.F S SCI=$O(^TMP("SCARR",$J,2,SCR)) Q:SCR="" D
..S SCI=""
..F S SCI=$O(^TMP("SCARR",$J,2,SCR,"PREC",SCI)) Q:SCI="" D
...S SCPRD=^TMP("SCARR",$J,2,SCR,"PREC",SCI)
...I $D(^TMP("SC",$J,"PCP",+SCPRD)) D PSET(SCPRD,SCPC,2,.SCN,"P",SCPP) S SCFOUND=1
...Q
..Q
.Q
I SCFAS!SCFPC Q SCFOUND
;Get all providers
S SCR="" F S SCR=$O(^TMP("SCARR",$J,2,SCR)) Q:SCR="" D
.F SCSUB="PROV-P","PROV-U","PREC" S SCI="" D
..Q:SCPC="NO"&(SCSUB="PREC") ;no preceptors for non-pc
..S SCLEV=$S(SCSUB="PREC":2,1:1)
..F S SCI=$O(^TMP("SCARR",$J,2,SCR,SCSUB,SCI)) Q:SCI="" D
...S SCPRD=^TMP("SCARR",$J,2,SCR,SCSUB,SCI)
...D PSET(SCPRD,SCPC,SCLEV,.SCN,$S(SCSUB="PREC":"P",1:"A"),$S(SCSUB="PROV-U":0,1:SCPP))
...Q
..Q
.Q
I '$O(SCPROV(0)) S SCPROV(1)="[not assigned]"_U_U_$S(SCPCF=0:"NPC",SCPCF=2:" AP",1:"PCP")
Q SCFOUND
;
PSET(SCPRD,SCPC,SCLEV,SCN,SCATY,SCPP) ;Set local provider array
;Input: SCRPD=provider data from PRTPC^SCAPMC
;Input: SCPC=pc? yes/no
;Input: SCLEV='1' for assigned position, '2' for preceptor position
;Input: SCN=array incrementing number
;Input: SCPTY='A' for assigned provider, 'P' for preceptor provider
;Input: SCPP='1' if preceptor position exists, '0' otherwise
N SCPRTY
S SCPRTY=$S(SCPC="NO":"NPC",SCLEV=1&SCPP:" AP",1:"PCP")
I SCATY="P",$P(SCPRD,U,14)>$P(SCPRD,U,9) D
.S $P(SCPRD,U,9)=$P(SCPRD,U,14),$P(SCPRD,U,10)=$P(SCPRD,U,15)
.Q
S SCN=SCN+1
S SCPROV(SCN)=$S($P(SCPRD,U,2)="":"[not assigned]",1:$P(SCPRD,U,2))
S SCPROV(SCN)=SCPROV(SCN)_U_+SCPRD_U_SCPRTY_U_SCATY_U
S SCPROV(SCN)=SCPROV(SCN)_$$DT($P(SCPRD,U,9))_U_$$DT($P(SCPRD,U,10))
Q
;
DT(X) ;Transform date
S X=$E(X,1,7) Q:X'?7N ""
Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_(17+$E(X))_$E(X,2,3)
;
PCROLE(SCPC) ;Determine PC? y/n
;Input: SCPC=pc role from file #404.43 (output as 'yes' or 'no' if successful)
;Output: '1' if successful, '0' otherwise
;
I $E(^TMP("SC",$J,"ATYPE"))="P",SCPC<1 Q 0
I $E(^TMP("SC",$J,"ATYPE"))="N",SCPC>0 Q 0
S SCPC=$S(SCPC>0:"YES",1:"NO")
Q 1
;
PTCL(DFN,SCLINIC,SCACT,SCINACT) ;evaluate enrolled clinic
;Input: DFN=patient ifn
;Input: SCLINIC=team position associated clinic
; (returned if successful and enrolled, null otherwise)
;Output: '1' if successful, '0' otherwise
;
N SCIFN,SCPE,ENR,SCPED,SCPED0
S SCIFN=$P(SCLINIC,U,2) Q:'SCIFN 1 ;not required, no associated clinic
I $D(^TMP("SC",$J,"CLINIC",SCIFN)),'$D(^DPT(DFN,"DE","B",SCIFN)) Q 0
;required, never enrolled
S (ENR,SCPE)=0
F S SCPE=$O(^DPT(DFN,"DE","B",SCIFN,SCPE)) Q:'SCPE!ENR D
.S SCPED=0 F S SCPED=$O(^DPT(DFN,"DE",SCPE,1,SCPED)) Q:'SCPED!ENR D
..S SCPED0=$G(^DPT(DFN,"DE",SCPE,1,SCPED,0)) Q:'+SCPED0
..I $P(SCPED0,U,3),$P(SCPED0,U,3)'<SCACT,+SCPED0'>SCINACT S ENR=1 Q
..I '$P(SCPED0,U,3),+SCPED0'>SCINACT S ENR=1
..Q
.Q
I $D(^TMP("SC",$J,"CLINIC",SCIFN)),'ENR S SCLINIC="" Q 0
I '$D(^TMP("SC",$J,"CLINIC",SCIFN)),'ENR S SCLINIC="" Q 1
Q 1
;
AGEGR(SCDT) ;Calculate age group
;Input: SCDT=patient birth date
N X,Y,X1,X2
S X1=DT,X2=SCDT D ^%DTC Q:X<0 "unknown"
S X=X\365.4 Q:X<5 "0 - 4"
S Y=X\5 S:'(Y#2) Y=Y-1
Q (Y*5)_" - "_(Y*5+9)
SCRPO2 ;BP-CIOFO/KEITH - Historical Patient Position Assignment Listing (cont.) ;7/31/99 22:36
+1 ;;5.3;Scheduling;**177,1015**;AUG 13, 1993;Build 21
+2 ;IHS/ANMC/LJF 11/02/2000 changed SSN to HRCN
+3 ; replaced elig/means test with gender/age
+4 ;
BPTPA(SCPASS,SCDIV,SCTEAM,SCPOS,SCLINIC,SCFMT) ;Evaluate patient team position assignment information
+1 ;Input: SCPASS=patient team position assignment information
+2 ; string from $$PTTP^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 SCPTPA,SCPTPA0,SCPC,DFN,SCPT0,SCACT,SCINACT,SCDT,SCPROV,SCX,SDOE0
+11 NEW SCS,SCI,SCY,SCATY,SCAGE,SCARR,SCENRP,SCGEND,SCLAPP,SCMTST,SCNAPP
+12 NEW SCPAT,SCPELIG,SCPTYP,SCSSN,ERR
+13 ;patient team position assignment
SET SCPTPA=$PIECE(SCPASS,U,3)
IF SCPTPA<1
QUIT
+14 SET SCPTPA0=$GET(^SCPT(404.43,+SCPTPA,0))
IF '$LENGTH(SCPTPA0)
QUIT
+15 ;activation dates
SET SCACT=$PIECE(SCPTPA0,U,3)
SET SCINACT=$PIECE(SCPTPA0,U,4)
+16 ;adjust dates if necessary
+17 IF SCACT<^TMP("SC",$JOB,"DTR","BEGIN")
SET SCACT=$PIECE(^TMP("SC",$JOB,"DTR","BEGIN"),U)
+18 IF 'SCINACT!(SCINACT>^TMP("SC",$JOB,"DTR","END"))
SET SCINACT=$PIECE(^TMP("SC",$JOB,"DTR","END"),U)
+19 ;pc role?
SET SCPC=$PIECE(SCPTPA0,U,5)
IF '$$PCROLE(.SCPC)
QUIT
+20 ;no pc providers here
IF $ORDER(^TMP("SC",$JOB,"PCP",0))
IF SCPC="NO"
QUIT
+21 ;patient node
SET DFN=$PIECE(SCPASS,U)
SET SCPT0=$GET(^DPT(+DFN,0))
IF '$LENGTH(SCPT0)
QUIT
+22 ;enrolled clinic
IF '$$PTCL(DFN,.SCLINIC,SCACT,SCINACT)
QUIT
+23 SET SCDT("BEGIN")=SCACT
SET SCDT("END")=SCINACT
SET SCDT("INCL")=0
SET SCDT="SCDT"
+24 SET SCARR="^TMP(""SCARR"",$J,2)"
KILL @SCARR
+25 SET SCI=$$PRTPC^SCAPMC($PIECE(SCPOS,U,2),.SCDT,SCARR,"ERR",1,1)
+26 ;providers
IF '$$PROV(.SCPROV,SCPC)
QUIT
+27 ;patient name^dfn
SET SCPAT=$PIECE(SCPT0,U)_U_DFN
+28 ;patient ssn
SET SCSSN=$PIECE(SCPT0,U,9)
+29 ;IHS/ANMC/LJF 11/2/2000
SET SCSSN=$$HRCN^BDGF2(DFN,+$GET(DUZ(2)))
+30 ;patient gender
SET SCGEND=$SELECT($PIECE(SCPT0,U,2)="M":"MALE",1:"FEMALE")
+31 ;patient age group
SET SCAGE=$$AGEGR($PIECE(SCPT0,U,3))
+32 ;primary eligibility
SET SCPELIG=$$ELIG^SCRPO(DFN)
+33 ;mt status
SET SCMTST=$PIECE($$LST^DGMTU(DFN,SCINACT),U,3,4)
+34 IF '$LENGTH(SCMTST)
SET SCMTST="(not applicable)^"
+35 KILL SCX
SET SDOE0=$PIECE(^TMP("SC",$JOB,"DTR","END"),U)_U_DFN
+36 ;enrollment priority
DO ENEP^SCRPW24(.SCX,"H")
SET SCENRP=$PIECE(SCX(1),U,2)
+37 ;
+38 ;Set data string
+39 ;S SCX=$E($P(SCPAT,U),1,18)_U_$E(SCSSN,6,10) ;IHS/ANMC/LJF 11/2/2000
+40 ;IHS/ANMC/LJF 11/2/2000
SET SCX=$EXTRACT($PIECE(SCPAT,U),1,18)_U_SCSSN
+41 ;S SCX=SCX_U_$P(SCPELIG,U,2)_U_$P(SCMTST,U,2) ;IHS/ANMC/LJF 11/2/2000
+42 SET SCX=SCX_U_$EXTRACT($PIECE(SCTEAM,U),1,13)_U_U_$EXTRACT($PIECE(SCPOS,U),1,14)_U
+43 SET SCX=SCX_U_$EXTRACT($PIECE(SCLINIC,U),1,14)
+44 ;
+45 ;Set line for each provider
+46 SET SCN=0
FOR
SET SCN=$ORDER(SCPROV(SCN))
IF 'SCN
QUIT
Begin DoDot:1
+47 SET SCPROV=$PIECE(SCPROV(SCN),U,1,2)
SET SCPTYP=$PIECE(SCPROV(SCN),U,3)
+48 SET SCATY=$SELECT($PIECE(SCPROV(SCN),U,4)="P":"PRECEPTOR PROVIDER",1:"ASSIGNED PROVIDER")
+49 SET $PIECE(SCX,U,6)=$EXTRACT($PIECE(SCPROV,U),1,14)
SET $PIECE(SCX,U,8)=SCPTYP
+50 SET $PIECE(SCX,U,10)=$PIECE(SCPROV(SCN),U,5,6)
+51 ;
+52 ;Set sort values
+53 IF SCFMT="D"
FOR SCI=1:1:6
SET SCS=$PIECE($GET(^TMP("SC",$JOB,"SORT",SCI)),U,3)
Begin DoDot:2
+54 IF $LENGTH(SCS)
SET SCY=@SCS
IF '$LENGTH(SCY)
SET SCY="~~~"
+55 IF '$LENGTH(SCS)
SET SCY="~~~"
SET SCS(SCI)=SCY
+56 QUIT
End DoDot:2
+57 ;Set report detail global
+58 IF SCFMT="D"
DO LSET(.SCS,SCX)
+59 ;
+60 ;Set report statistics nodes
+61 SET ^TMP("SCRPT",$JOB,0,SCATY,SCPROV)=$GET(^TMP("SCRPT",$JOB,0,SCATY,SCPROV))+1
End DoDot:1
+62 IF $LENGTH(SCPELIG)
SET ^TMP("SCRPT",$JOB,0,"PRIMARY ELIGIBILITY",SCPELIG)=$GET(^TMP("SCRPT",$JOB,0,"PRIMARY ELIGIBILITY",SCPELIG))+1
+63 IF $LENGTH(SCMTST)
SET ^TMP("SCRPT",$JOB,0,"MEANS TEST CATEGORY",SCMTST)=$GET(^TMP("SCRPT",$JOB,0,"MEANS TEST CATEGORY",SCMTST))+1
+64 SET ^TMP("SCRPT",$JOB,0,"GENDER",SCGEND)=$GET(^TMP("SCRPT",$JOB,0,"GENDER",SCGEND))+1
+65 SET ^TMP("SCRPT",$JOB,0,"AGE GROUP",SCAGE)=$GET(^TMP("SCRPT",$JOB,0,"AGE GROUP",SCAGE))+1
+66 SET ^TMP("SCRPT",$JOB,0,"NATIONAL ENROLLMENT PRIORITY",SCENRP)=$GET(^TMP("SCRPT",$JOB,0,"NATIONAL ENROLLMENT PRIORITY",SCENRP))+1
+67 SET ^TMP("SCRPT",$JOB,0,"TEAM",SCTEAM)=$GET(^TMP("SCRPT",$JOB,0,"TEAM",SCTEAM))+1
+68 SET ^TMP("SCRPT",$JOB,0,"PRIMARY CARE",SCPC)=$GET(^TMP("SCRPT",$JOB,0,"PRIMARY CARE",SCPC))+1
+69 SET ^TMP("SCRPT",$JOB,0,"DIVISION",SCDIV)=$GET(^TMP("SCRPT",$JOB,0,"DIVISION",SCDIV))+1
+70 SET ^TMP("SCRPT",$JOB,0,"ASSIGNMENTS")=$GET(^TMP("SCRPT",$JOB,0,"ASSIGNMENTS"))+1
+71 SET ^TMP("SCRPT",$JOB,0,"UNIQUES",DFN)=""
+72 QUIT
+73 ;
LSET(SCS,SCX) ;Set report line
+1 ;Input: SCS=array of sort values
+2 ;Input: SCX=data string
+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),SCS(6),SCL)=SCX
+12 QUIT
+13 ;
PROV(SCPROV,SCPC) ;evaluate providers
+1 ;Input: SCPROV=variable to return array of provider^ifn^type
+2 ;Input: SCPC=pc? yes/no
+3 ;Output: '1' if successful, '0' otherwise
+4 ;
+5 NEW SCI,SCPCF,SCFOUND,SCFPC,SCFAS,SCPRD,SCN,SCSUB,SCLEV,SCR,SCPP
+6 ;find pc provider flag
SET SCFPC=$ORDER(^TMP("SC",$JOB,"PCP",0))>0
+7 ;find assigned provider flag
SET SCFAS=$ORDER(^TMP("SC",$JOB,"ASPR",0))>0
+8 SET SCPCF=$SELECT(SCPC="NO":0,$DATA(^TMP("SCARR",$JOB,2,"PPROV")):2,1:1)
SET SCN=0
+9 ;success indicator
SET SCFOUND=$SELECT(SCFPC!SCFAS:0,1:1)
+10 SET SCPP=0
SET SCR=""
FOR
SET SCR=$ORDER(^TMP("SCARR",$JOB,2,SCR))
IF 'SCR!SCPP
QUIT
Begin DoDot:1
+11 IF $DATA(^TMP("SCARR",$JOB,2,SCR,"PREC"))
SET SCPP=1
+12 ;Preceptor position flag
QUIT
End DoDot:1
+13 ;Find selected assigned providers
IF SCFAS
Begin DoDot:1
+14 SET SCR=""
+15 FOR
SET SCI=$ORDER(^TMP("SCARR",$JOB,2,SCR))
IF SCR=""
QUIT
Begin DoDot:2
+16 SET SCI=""
+17 FOR
SET SCI=$ORDER(^TMP("SCARR",$JOB,2,SCR,"PROV-P",SCI))
IF SCI=""
QUIT
Begin DoDot:3
+18 SET SCPRD=^TMP("SCARR",$JOB,2,SCR,"PROV-P",SCI)
+19 IF $DATA(^TMP("SC",$JOB,"ASPR",+SCPRD))
DO PSET(SCPRD,SCPC,1,.SCN,"A",SCPP)
SET SCFOUND=1
+20 QUIT
End DoDot:3
+21 QUIT
End DoDot:2
+22 SET SCR=""
+23 FOR
SET SCI=$ORDER(^TMP("SCARR",$JOB,2,SCR))
IF SCR=""
QUIT
Begin DoDot:2
+24 SET SCI=""
+25 FOR
SET SCI=$ORDER(^TMP("SCARR",$JOB,2,SCR,"PROV-U",SCI))
IF SCI=""
QUIT
Begin DoDot:3
+26 SET SCPRD=^TMP("SCARR",$JOB,2,SCR,"PROV-U",SCI)
+27 IF $DATA(^TMP("SC",$JOB,"ASPR",+SCPRD))
DO PSET(SCPRD,SCPC,1,.SCN,"A",0)
SET SCFOUND=1
+28 QUIT
End DoDot:3
+29 QUIT
End DoDot:2
+30 QUIT
End DoDot:1
+31 ;Find selected pc providers in top level
IF SCFPC
IF 'SCPP
Begin DoDot:1
+32 SET SCR=""
+33 FOR
SET SCI=$ORDER(^TMP("SCARR",$JOB,2,SCR))
IF SCR=""
QUIT
Begin DoDot:2
+34 SET SCI=""
+35 FOR
SET SCI=$ORDER(^TMP("SCARR",$JOB,2,SCR,"PROV-U",SCI))
IF SCI=""
QUIT
Begin DoDot:3
+36 SET SCPRD=^TMP("SCARR",$JOB,2,SCR,"PROV-U",SCI)
+37 IF $DATA(^TMP("SC",$JOB,"PCP",+SCPRD))
DO PSET(SCPRD,SCPC,1,.SCN,"A",SCPP)
SET SCFOUND=1
+38 QUIT
End DoDot:3
+39 QUIT
End DoDot:2
+40 QUIT
End DoDot:1
+41 ;Find selected pc providers in preceptor level
IF SCFPC
IF SCPP
Begin DoDot:1
+42 SET SCR=""
+43 FOR
SET SCI=$ORDER(^TMP("SCARR",$JOB,2,SCR))
IF SCR=""
QUIT
Begin DoDot:2
+44 SET SCI=""
+45 FOR
SET SCI=$ORDER(^TMP("SCARR",$JOB,2,SCR,"PREC",SCI))
IF SCI=""
QUIT
Begin DoDot:3
+46 SET SCPRD=^TMP("SCARR",$JOB,2,SCR,"PREC",SCI)
+47 IF $DATA(^TMP("SC",$JOB,"PCP",+SCPRD))
DO PSET(SCPRD,SCPC,2,.SCN,"P",SCPP)
SET SCFOUND=1
+48 QUIT
End DoDot:3
+49 QUIT
End DoDot:2
+50 QUIT
End DoDot:1
+51 IF SCFAS!SCFPC
QUIT SCFOUND
+52 ;Get all providers
+53 SET SCR=""
FOR
SET SCR=$ORDER(^TMP("SCARR",$JOB,2,SCR))
IF SCR=""
QUIT
Begin DoDot:1
+54 FOR SCSUB="PROV-P","PROV-U","PREC"
SET SCI=""
Begin DoDot:2
+55 ;no preceptors for non-pc
IF SCPC="NO"&(SCSUB="PREC")
QUIT
+56 SET SCLEV=$SELECT(SCSUB="PREC":2,1:1)
+57 FOR
SET SCI=$ORDER(^TMP("SCARR",$JOB,2,SCR,SCSUB,SCI))
IF SCI=""
QUIT
Begin DoDot:3
+58 SET SCPRD=^TMP("SCARR",$JOB,2,SCR,SCSUB,SCI)
+59 DO PSET(SCPRD,SCPC,SCLEV,.SCN,$SELECT(SCSUB="PREC":"P",1:"A"),$SELECT(SCSUB="PROV-U":0,1:SCPP))
+60 QUIT
End DoDot:3
+61 QUIT
End DoDot:2
+62 QUIT
End DoDot:1
+63 IF '$ORDER(SCPROV(0))
SET SCPROV(1)="[not assigned]"_U_U_$SELECT(SCPCF=0:"NPC",SCPCF=2:" AP",1:"PCP")
+64 QUIT SCFOUND
+65 ;
PSET(SCPRD,SCPC,SCLEV,SCN,SCATY,SCPP) ;Set local provider array
+1 ;Input: SCRPD=provider data from PRTPC^SCAPMC
+2 ;Input: SCPC=pc? yes/no
+3 ;Input: SCLEV='1' for assigned position, '2' for preceptor position
+4 ;Input: SCN=array incrementing number
+5 ;Input: SCPTY='A' for assigned provider, 'P' for preceptor provider
+6 ;Input: SCPP='1' if preceptor position exists, '0' otherwise
+7 NEW SCPRTY
+8 SET SCPRTY=$SELECT(SCPC="NO":"NPC",SCLEV=1&SCPP:" AP",1:"PCP")
+9 IF SCATY="P"
IF $PIECE(SCPRD,U,14)>$PIECE(SCPRD,U,9)
Begin DoDot:1
+10 SET $PIECE(SCPRD,U,9)=$PIECE(SCPRD,U,14)
SET $PIECE(SCPRD,U,10)=$PIECE(SCPRD,U,15)
+11 QUIT
End DoDot:1
+12 SET SCN=SCN+1
+13 SET SCPROV(SCN)=$SELECT($PIECE(SCPRD,U,2)="":"[not assigned]",1:$PIECE(SCPRD,U,2))
+14 SET SCPROV(SCN)=SCPROV(SCN)_U_+SCPRD_U_SCPRTY_U_SCATY_U
+15 SET SCPROV(SCN)=SCPROV(SCN)_$$DT($PIECE(SCPRD,U,9))_U_$$DT($PIECE(SCPRD,U,10))
+16 QUIT
+17 ;
DT(X) ;Transform date
+1 SET X=$EXTRACT(X,1,7)
IF X'?7N
QUIT ""
+2 QUIT $EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_(17+$EXTRACT(X))_$EXTRACT(X,2,3)
+3 ;
PCROLE(SCPC) ;Determine PC? y/n
+1 ;Input: SCPC=pc role from file #404.43 (output as 'yes' or 'no' if successful)
+2 ;Output: '1' if successful, '0' otherwise
+3 ;
+4 IF $EXTRACT(^TMP("SC",$JOB,"ATYPE"))="P"
IF SCPC<1
QUIT 0
+5 IF $EXTRACT(^TMP("SC",$JOB,"ATYPE"))="N"
IF SCPC>0
QUIT 0
+6 SET SCPC=$SELECT(SCPC>0:"YES",1:"NO")
+7 QUIT 1
+8 ;
PTCL(DFN,SCLINIC,SCACT,SCINACT) ;evaluate enrolled clinic
+1 ;Input: DFN=patient ifn
+2 ;Input: SCLINIC=team position associated clinic
+3 ; (returned if successful and enrolled, null otherwise)
+4 ;Output: '1' if successful, '0' otherwise
+5 ;
+6 NEW SCIFN,SCPE,ENR,SCPED,SCPED0
+7 ;not required, no associated clinic
SET SCIFN=$PIECE(SCLINIC,U,2)
IF 'SCIFN
QUIT 1
+8 IF $DATA(^TMP("SC",$JOB,"CLINIC",SCIFN))
IF '$DATA(^DPT(DFN,"DE","B",SCIFN))
QUIT 0
+9 ;required, never enrolled
+10 SET (ENR,SCPE)=0
+11 FOR
SET SCPE=$ORDER(^DPT(DFN,"DE","B",SCIFN,SCPE))
IF 'SCPE!ENR
QUIT
Begin DoDot:1
+12 SET SCPED=0
FOR
SET SCPED=$ORDER(^DPT(DFN,"DE",SCPE,1,SCPED))
IF 'SCPED!ENR
QUIT
Begin DoDot:2
+13 SET SCPED0=$GET(^DPT(DFN,"DE",SCPE,1,SCPED,0))
IF '+SCPED0
QUIT
+14 IF $PIECE(SCPED0,U,3)
IF $PIECE(SCPED0,U,3)'<SCACT
IF +SCPED0'>SCINACT
SET ENR=1
QUIT
+15 IF '$PIECE(SCPED0,U,3)
IF +SCPED0'>SCINACT
SET ENR=1
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 IF $DATA(^TMP("SC",$JOB,"CLINIC",SCIFN))
IF 'ENR
SET SCLINIC=""
QUIT 0
+19 IF '$DATA(^TMP("SC",$JOB,"CLINIC",SCIFN))
IF 'ENR
SET SCLINIC=""
QUIT 1
+20 QUIT 1
+21 ;
AGEGR(SCDT) ;Calculate age group
+1 ;Input: SCDT=patient birth date
+2 NEW X,Y,X1,X2
+3 SET X1=DT
SET X2=SCDT
DO ^%DTC
IF X<0
QUIT "unknown"
+4 SET X=X\365.4
IF X<5
QUIT "0 - 4"
+5 SET Y=X\5
IF '(Y#2)
SET Y=Y-1
+6 QUIT (Y*5)_" - "_(Y*5+9)
