Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SCRPO2

SCRPO2.m

Go to the documentation of this file. 
  1. SCRPO2 ;BP-CIOFO/KEITH - Historical Patient Position Assignment Listing (cont.) ;7/31/99  22:36
  1.  ;;5.3;Scheduling;**177**;AUG 13, 1993
  1.  ;
  1. BPTPA(SCPASS,SCDIV,SCTEAM,SCPOS,SCLINIC,SCFMT) ;Evaluate patient team position assignment information
  1.  ;Input: SCPASS=patient team position assignment information
  1.  ;              string from $$PTTP^SCAPMC
  1.  ;Input: SCDIV=division^ifn 
  1.  ;Input: SCTEAM=team^ifn 
  1.  ;Input: SCPOS=team position^ifn 
  1.  ;Input: SCLINIC=associated clinic^ifn (if one exists)
  1.  ;Input: SCFMT=report format (detail or summary)
  1.  ;
  1.  ;evaluate assignment/gather data
  1.  N SCPTPA,SCPTPA0,SCPC,DFN,SCPT0,SCACT,SCINACT,SCDT,SCPROV,SCX,SDOE0
  1.  N SCS,SCI,SCY,SCATY,SCAGE,SCARR,SCENRP,SCGEND,SCLAPP,SCMTST,SCNAPP
  1.  N SCPAT,SCPELIG,SCPTYP,SCSSN,ERR
  1.  S SCPTPA=$P(SCPASS,U,3) Q:SCPTPA<1  ;patient team position assignment
  1.  S SCPTPA0=$G(^SCPT(404.43,+SCPTPA,0)) Q:'$L(SCPTPA0)
  1.  S SCACT=$P(SCPTPA0,U,3),SCINACT=$P(SCPTPA0,U,4)  ;activation dates
  1.  ;adjust dates if necessary
  1.  S:SCACT<^TMP("SC",$J,"DTR","BEGIN") SCACT=$P(^TMP("SC",$J,"DTR","BEGIN"),U)
  1.  I 'SCINACT!(SCINACT>^TMP("SC",$J,"DTR","END")) S SCINACT=$P(^TMP("SC",$J,"DTR","END"),U)
  1.  S SCPC=$P(SCPTPA0,U,5) Q:'$$PCROLE(.SCPC)  ;pc role?
  1.  I $O(^TMP("SC",$J,"PCP",0)),SCPC="NO" Q  ;no pc providers here
  1.  S DFN=$P(SCPASS,U),SCPT0=$G(^DPT(+DFN,0)) Q:'$L(SCPT0)  ;patient node
  1.  Q:'$$PTCL(DFN,.SCLINIC,SCACT,SCINACT)  ;enrolled clinic
  1.  S SCDT("BEGIN")=SCACT,SCDT("END")=SCINACT,SCDT("INCL")=0,SCDT="SCDT"
  1.  S SCARR="^TMP(""SCARR"",$J,2)" K @SCARR
  1.  S SCI=$$PRTPC^SCAPMC($P(SCPOS,U,2),.SCDT,SCARR,"ERR",1,1)
  1.  Q:'$$PROV(.SCPROV,SCPC)  ;providers
  1.  S SCPAT=$P(SCPT0,U)_U_DFN  ;patient name^dfn
  1.  S SCSSN=$P(SCPT0,U,9)  ;patient ssn
  1.  S SCGEND=$S($P(SCPT0,U,2)="M":"MALE",1:"FEMALE")  ;patient gender
  1.  S SCAGE=$$AGEGR($P(SCPT0,U,3))  ;patient age group
  1.  S SCPELIG=$$ELIG^SCRPO(DFN)  ;primary eligibility
  1.  S SCMTST=$P($$LST^DGMTU(DFN,SCINACT),U,3,4)  ;mt status
  1.  S:'$L(SCMTST) SCMTST="(not applicable)^"
  1.  K SCX S SDOE0=$P(^TMP("SC",$J,"DTR","END"),U)_U_DFN
  1.  D ENEP^SCRPW24(.SCX,"H") S SCENRP=$P(SCX(1),U,2)  ;enrollment priority
  1.  ;
  1.  ;Set data string
  1.  S SCX=$E($P(SCPAT,U),1,18)_U_$E(SCSSN,6,10)
  1.  S SCX=SCX_U_$P(SCPELIG,U,2)_U_$P(SCMTST,U,2)
  1.  S SCX=SCX_U_$E($P(SCTEAM,U),1,13)_U_U_$E($P(SCPOS,U),1,14)_U
  1.  S SCX=SCX_U_$E($P(SCLINIC,U),1,14)
  1.  ;
  1.  ;Set line for each provider
  1.  S SCN=0 F  S SCN=$O(SCPROV(SCN)) Q:'SCN  D
  1.  .S SCPROV=$P(SCPROV(SCN),U,1,2),SCPTYP=$P(SCPROV(SCN),U,3)
  1.  .S SCATY=$S($P(SCPROV(SCN),U,4)="P":"PRECEPTOR PROVIDER",1:"ASSIGNED PROVIDER")
  1.  .S $P(SCX,U,6)=$E($P(SCPROV,U),1,14),$P(SCX,U,8)=SCPTYP
  1.  .S $P(SCX,U,10)=$P(SCPROV(SCN),U,5,6)
  1.  .;
  1.  .;Set sort values
  1.  .I SCFMT="D" F SCI=1:1:6 S SCS=$P($G(^TMP("SC",$J,"SORT",SCI)),U,3) D
  1.  ..I $L(SCS) S SCY=@SCS S:'$L(SCY) SCY="~~~"
  1.  ..S:'$L(SCS) SCY="~~~" S SCS(SCI)=SCY
  1.  ..Q
  1.  .;Set report detail global
  1.  .I SCFMT="D" D LSET(.SCS,SCX)
  1.  .;
  1.  .;Set report statistics nodes
  1.  .S ^TMP("SCRPT",$J,0,SCATY,SCPROV)=$G(^TMP("SCRPT",$J,0,SCATY,SCPROV))+1
  1.  I $L(SCPELIG) S ^TMP("SCRPT",$J,0,"PRIMARY ELIGIBILITY",SCPELIG)=$G(^TMP("SCRPT",$J,0,"PRIMARY ELIGIBILITY",SCPELIG))+1
  1.  I $L(SCMTST) S ^TMP("SCRPT",$J,0,"MEANS TEST CATEGORY",SCMTST)=$G(^TMP("SCRPT",$J,0,"MEANS TEST CATEGORY",SCMTST))+1
  1.  S ^TMP("SCRPT",$J,0,"GENDER",SCGEND)=$G(^TMP("SCRPT",$J,0,"GENDER",SCGEND))+1
  1.  S ^TMP("SCRPT",$J,0,"AGE GROUP",SCAGE)=$G(^TMP("SCRPT",$J,0,"AGE GROUP",SCAGE))+1
  1.  S ^TMP("SCRPT",$J,0,"NATIONAL ENROLLMENT PRIORITY",SCENRP)=$G(^TMP("SCRPT",$J,0,"NATIONAL ENROLLMENT PRIORITY",SCENRP))+1
  1.  S ^TMP("SCRPT",$J,0,"TEAM",SCTEAM)=$G(^TMP("SCRPT",$J,0,"TEAM",SCTEAM))+1
  1.  S ^TMP("SCRPT",$J,0,"PRIMARY CARE",SCPC)=$G(^TMP("SCRPT",$J,0,"PRIMARY CARE",SCPC))+1
  1.  S ^TMP("SCRPT",$J,0,"DIVISION",SCDIV)=$G(^TMP("SCRPT",$J,0,"DIVISION",SCDIV))+1
  1.  S ^TMP("SCRPT",$J,0,"ASSIGNMENTS")=$G(^TMP("SCRPT",$J,0,"ASSIGNMENTS"))+1
  1.  S ^TMP("SCRPT",$J,0,"UNIQUES",DFN)=""
  1.  Q
  1.  ;
  1. LSET(SCS,SCX) ;Set report line
  1.  ;Input: SCS=array of sort values
  1.  ;Input: SCX=data string
  1.  N SCI,SCN,SCL
  1.  S SCN=$G(^TMP("SCRPT",$J,1,SCS(1),SCS(2),SCS(3))) I 'SCN D
  1.  .S ^TMP("SCRPT",$J,1)=$G(^TMP("SCRPT",$J,1))+1
  1.  .S SCN=^TMP("SCRPT",$J,1)
  1.  .S ^TMP("SCRPT",$J,1,SCS(1),SCS(2),SCS(3))=SCN
  1.  .Q
  1.  S ^TMP("SCRPT",$J,2)=$G(^TMP("SCRPT",$J,2))+1
  1.  S SCL=^TMP("SCRPT",$J,2)
  1.  S ^TMP("SCRPT",$J,2,SCN,SCS(4),SCS(5),SCS(6),SCL)=SCX
  1.  Q
  1.  ;
  1. PROV(SCPROV,SCPC) ;evaluate providers
  1.  ;Input: SCPROV=variable to return array of provider^ifn^type
  1.  ;Input: SCPC=pc? yes/no
  1.  ;Output: '1' if successful, '0' otherwise
  1.  ;
  1.  N SCI,SCPCF,SCFOUND,SCFPC,SCFAS,SCPRD,SCN,SCSUB,SCLEV,SCR,SCPP
  1.  S SCFPC=$O(^TMP("SC",$J,"PCP",0))>0  ;find pc provider flag
  1.  S SCFAS=$O(^TMP("SC",$J,"ASPR",0))>0  ;find assigned provider flag
  1.  S SCPCF=$S(SCPC="NO":0,$D(^TMP("SCARR",$J,2,"PPROV")):2,1:1),SCN=0
  1.  S SCFOUND=$S(SCFPC!SCFAS:0,1:1)  ;success indicator
  1.  S SCPP=0,SCR="" F  S SCR=$O(^TMP("SCARR",$J,2,SCR)) Q:'SCR!SCPP  D
  1.  .S:$D(^TMP("SCARR",$J,2,SCR,"PREC")) SCPP=1
  1.  .Q  ;Preceptor position flag
  1.  I SCFAS D  ;Find selected assigned providers
  1.  .S SCR=""
  1.  .F  S SCI=$O(^TMP("SCARR",$J,2,SCR)) Q:SCR=""  D
  1.  ..S SCI=""
  1.  ..F  S SCI=$O(^TMP("SCARR",$J,2,SCR,"PROV-P",SCI)) Q:SCI=""  D
  1.  ...S SCPRD=^TMP("SCARR",$J,2,SCR,"PROV-P",SCI)
  1.  ...I $D(^TMP("SC",$J,"ASPR",+SCPRD)) D PSET(SCPRD,SCPC,1,.SCN,"A",SCPP) S SCFOUND=1
  1.  ...Q
  1.  ..Q
  1.  .S SCR=""
  1.  .F  S SCI=$O(^TMP("SCARR",$J,2,SCR)) Q:SCR=""  D
  1.  ..S SCI=""
  1.  ..F  S SCI=$O(^TMP("SCARR",$J,2,SCR,"PROV-U",SCI)) Q:SCI=""  D
  1.  ...S SCPRD=^TMP("SCARR",$J,2,SCR,"PROV-U",SCI)
  1.  ...I $D(^TMP("SC",$J,"ASPR",+SCPRD)) D PSET(SCPRD,SCPC,1,.SCN,"A",0) S SCFOUND=1
  1.  ...Q
  1.  ..Q
  1.  .Q
  1.  I SCFPC,'SCPP D  ;Find selected pc providers in top level
  1.  .S SCR=""
  1.  .F  S SCI=$O(^TMP("SCARR",$J,2,SCR)) Q:SCR=""  D
  1.  ..S SCI=""
  1.  ..F  S SCI=$O(^TMP("SCARR",$J,2,SCR,"PROV-U",SCI)) Q:SCI=""  D
  1.  ...S SCPRD=^TMP("SCARR",$J,2,SCR,"PROV-U",SCI)
  1.  ...I $D(^TMP("SC",$J,"PCP",+SCPRD)) D PSET(SCPRD,SCPC,1,.SCN,"A",SCPP) S SCFOUND=1
  1.  ...Q
  1.  ..Q
  1.  .Q
  1.  I SCFPC,SCPP D  ;Find selected pc providers in preceptor level
  1.  .S SCR=""
  1.  .F  S SCI=$O(^TMP("SCARR",$J,2,SCR)) Q:SCR=""  D
  1.  ..S SCI=""
  1.  ..F  S SCI=$O(^TMP("SCARR",$J,2,SCR,"PREC",SCI)) Q:SCI=""  D
  1.  ...S SCPRD=^TMP("SCARR",$J,2,SCR,"PREC",SCI)
  1.  ...I $D(^TMP("SC",$J,"PCP",+SCPRD)) D PSET(SCPRD,SCPC,2,.SCN,"P",SCPP) S SCFOUND=1
  1.  ...Q
  1.  ..Q
  1.  .Q
  1.  I SCFAS!SCFPC Q SCFOUND
  1.  ;Get all providers
  1.  S SCR="" F  S SCR=$O(^TMP("SCARR",$J,2,SCR)) Q:SCR=""  D
  1.  .F SCSUB="PROV-P","PROV-U","PREC" S SCI="" D
  1.  ..Q:SCPC="NO"&(SCSUB="PREC")  ;no preceptors for non-pc
  1.  ..S SCLEV=$S(SCSUB="PREC":2,1:1)
  1.  ..F  S SCI=$O(^TMP("SCARR",$J,2,SCR,SCSUB,SCI)) Q:SCI=""  D
  1.  ...S SCPRD=^TMP("SCARR",$J,2,SCR,SCSUB,SCI)
  1.  ...D PSET(SCPRD,SCPC,SCLEV,.SCN,$S(SCSUB="PREC":"P",1:"A"),$S(SCSUB="PROV-U":0,1:SCPP))
  1.  ...Q
  1.  ..Q
  1.  .Q
  1.  I '$O(SCPROV(0)) S SCPROV(1)="[not assigned]"_U_U_$S(SCPCF=0:"NPC",SCPCF=2:" AP",1:"PCP")
  1.  Q SCFOUND
  1.  ;
  1. PSET(SCPRD,SCPC,SCLEV,SCN,SCATY,SCPP) ;Set local provider array
  1.  ;Input: SCRPD=provider data from PRTPC^SCAPMC
  1.  ;Input: SCPC=pc? yes/no
  1.  ;Input: SCLEV='1' for assigned position, '2' for preceptor position
  1.  ;Input: SCN=array incrementing number
  1.  ;Input: SCPTY='A' for assigned provider, 'P' for preceptor provider
  1.  ;Input: SCPP='1' if preceptor position exists, '0' otherwise
  1.  N SCPRTY
  1.  S SCPRTY=$S(SCPC="NO":"NPC",SCLEV=1&SCPP:" AP",1:"PCP")
  1.  I SCATY="P",$P(SCPRD,U,14)>$P(SCPRD,U,9) D
  1.  .S $P(SCPRD,U,9)=$P(SCPRD,U,14),$P(SCPRD,U,10)=$P(SCPRD,U,15)
  1.  .Q
  1.  S SCN=SCN+1
  1.  S SCPROV(SCN)=$S($P(SCPRD,U,2)="":"[not assigned]",1:$P(SCPRD,U,2))
  1.  S SCPROV(SCN)=SCPROV(SCN)_U_+SCPRD_U_SCPRTY_U_SCATY_U
  1.  S SCPROV(SCN)=SCPROV(SCN)_$$DT($P(SCPRD,U,9))_U_$$DT($P(SCPRD,U,10))
  1.  Q 
  1.  ;
  1. DT(X) ;Transform date
  1.  S X=$E(X,1,7) Q:X'?7N ""
  1.  Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_(17+$E(X))_$E(X,2,3)
  1.  ;
  1. PCROLE(SCPC) ;Determine PC? y/n
  1.  ;Input: SCPC=pc role from file #404.43 (output as 'yes' or 'no' if successful)
  1.  ;Output: '1' if successful, '0' otherwise
  1.  ;
  1.  I $E(^TMP("SC",$J,"ATYPE"))="P",SCPC<1 Q 0
  1.  I $E(^TMP("SC",$J,"ATYPE"))="N",SCPC>0 Q 0
  1.  S SCPC=$S(SCPC>0:"YES",1:"NO")
  1.  Q 1
  1.  ;
  1. PTCL(DFN,SCLINIC,SCACT,SCINACT) ;evaluate enrolled clinic
  1.  ;Input: DFN=patient ifn
  1.  ;Input: SCLINIC=team position associated clinic 
  1.  ;       (returned if successful and enrolled, null otherwise)
  1.  ;Output: '1' if successful, '0' otherwise
  1.  ;
  1.  N SCIFN,SCPE,ENR,SCPED,SCPED0
  1.  S SCIFN=$P(SCLINIC,U,2) Q:'SCIFN 1  ;not required, no associated clinic
  1.  I $D(^TMP("SC",$J,"CLINIC",SCIFN)),'$D(^DPT(DFN,"DE","B",SCIFN)) Q 0
  1.  ;required, never enrolled
  1.  S (ENR,SCPE)=0
  1.  F  S SCPE=$O(^DPT(DFN,"DE","B",SCIFN,SCPE)) Q:'SCPE!ENR  D
  1.  .S SCPED=0 F  S SCPED=$O(^DPT(DFN,"DE",SCPE,1,SCPED)) Q:'SCPED!ENR  D
  1.  ..S SCPED0=$G(^DPT(DFN,"DE",SCPE,1,SCPED,0)) Q:'+SCPED0
  1.  ..I $P(SCPED0,U,3),$P(SCPED0,U,3)'<SCACT,+SCPED0'>SCINACT S ENR=1 Q
  1.  ..I '$P(SCPED0,U,3),+SCPED0'>SCINACT S ENR=1
  1.  ..Q
  1.  .Q
  1.  I $D(^TMP("SC",$J,"CLINIC",SCIFN)),'ENR S SCLINIC="" Q 0
  1.  I '$D(^TMP("SC",$J,"CLINIC",SCIFN)),'ENR S SCLINIC="" Q 1
  1.  Q 1
  1.  ;
  1. AGEGR(SCDT) ;Calculate age group
  1.  ;Input: SCDT=patient birth date
  1.  N X,Y,X1,X2
  1.  S X1=DT,X2=SCDT D ^%DTC Q:X<0 "unknown"
  1.  S X=X\365.4 Q:X<5 "0 - 4"
  1.  S Y=X\5 S:'(Y#2) Y=Y-1
  1.  Q (Y*5)_" - "_(Y*5+9)