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

SCRPO1.m

Go to the documentation of this file. 
  1. SCRPO1 ;BP-CIOFO/KEITH - Historical Patient Position Assignment Listing ; 20 Aug 99  7:49 AM
  1.  ;;5.3;Scheduling;**177,1015**;AUG 13, 1993;Build 21
  1.  ;IHS/ANMC/LJF 11/02/2000 changed 132 column message
  1.  ;                        added call to list template & header
  1.  ;                        moved IO variables kill to list template
  1.  ;                        changed footer code for list template
  1.  ;                        moved spacing of columns
  1.  ;                        removed elig & means test from summary
  1.  ;
  1. EN ;Queue report
  1.  N LIST,SORT,SCSP,RTN,DESC
  1.  S LIST="DIV,TEAM,POS,PCP,ASPR,CLINIC",SORT="DV,TM,TP,PR,EC,PA"
  1.  S SCSP="PA",RTN="RUN^SCRPO1"
  1.  S DESC="Historical Patient Position Assignment Listing"
  1.  D PROMPT(LIST,SORT,SCSP,RTN,DESC) Q
  1.  ;
  1. PROMPT(LIST,SORT,SCSP,SCRTN,SCDESC) ;Prompt for report parameters, queue report
  1.  ;Input: LIST=comma delimited string of list subscripts to prompt for
  1.  ;Input: SORT=comma delimited string of sort acronyms to prompt for
  1.  ;Input: SCSP=acronym of last sort to add if not selected (optional)
  1.  ;Input: SCRTN=report routine entry point
  1.  ;Input: SCDESC=tasked job description
  1.  ;
  1.  N SCDIV,SCBDT,SCEDT,SC,SCI,SCX,SCOUT,SCT
  1.  S SC="^TMP(""SC"",$J)" K @SC S SCOUT=0
  1.  D TITL^SCRPW50(SCDESC)
  1.  D SUBT^SCRPW50("**** Date Range Selection ****")
  1.  S (SCBDT("B"),SCEDT("B"))="TODAY"
  1.  G:'$$DTR^SCRPO(.SC,.SCBDT,.SCEDT) END
  1.  D SUBT^SCRPW50("**** Report Parameter Selection ****")
  1.  G:'$$ATYPE^SCRPO(.SC) END
  1.  G:'$$DSUM^SCRPO(.SC) END
  1.  F SCI=1:1:$L(LIST,",") S SCX=$P(LIST,",",SCI) D  Q:SCOUT
  1.  .S SCOUT='$$LIST^SCRPO(.SC,SCX,1)
  1.  .Q
  1.  G:SCOUT END
  1.  D SUBT^SCRPW50("**** Output sort order (optional) ****")
  1.  G:'$$SORT^SCRPO(.SC,SORT,SCSP) END
  1.  S SCT(1)="**** Report Parameters Selected ****" D SUBT^SCRPW50(SCT(1))
  1.  G:'$$PPAR^SCRPO(.SC,1,.SCT) END
  1.  ;W !!,"This report requires 132 column output!"  ;IHS/ANMC/LJF 11/2/2000
  1.  W !!,"This report, when printed on paper, requires wide paper or condensed print!"  ;IHS/ANMC/LJF 11/2/2000
  1.  W ! N ZTSAVE S ZTSAVE("^TMP(""SC"",$J,")="",ZTSAVE("SC")=""
  1.  D EN^XUTMDEVQ(SCRTN,SCDESC,.ZTSAVE)
  1. END K ^TMP("SC",$J) D DISP0^SCRPW23,END^SCRPW50 Q
  1.  ;
  1. RUN ;Print report
  1.  I $E(IOST,1,2)="C-" D ^BSDSCO1 Q   ;IHS/ANMC/LJF 11/2/2000
  1. IHS ;EP; entry point for list template ;IHS/ANMC/LJF 11/2/2000
  1.  N SCFMT,SCTITL,SCTITL2,SCLINE,SCPAGE,SCOUT,SCFF,SCX,SCFF,SCLINE,SCPAGE
  1.  N SC1,SC2,SC3,SC4,SC5,SC6,SC7,SCN,SCASP,SCUNP,SCI,SCPNOW
  1.  S SCFMT=$E(^TMP("SC",$J,"FMT")),(SCFF,SCOUT,SCUNP)=0
  1.  D BUILD(SCFMT) Q:SCOUT  S SCI=0
  1.  F  S SCI=$O(^TMP("SCRPT",$J,0,"UNIQUES",SCI)) Q:'SCI  S SCUNP=SCUNP+1
  1.  D HINI D:$E(IOST)="C" DISP0^SCRPW23
  1.  S SCTITL(2)=$$HDRX("P") D HDR^SCRPO(.SCTITL,132) Q:SCOUT  S SCOUT=$$PPAR^SCRPO(.SC,,.SCTITL)=0
  1.  Q:SCOUT
  1.  I '$D(^TMP("SCRPT",$J,0)) D  G EXIT
  1.  .K SCTITL(2) D HDR^SCRPO(.SCTITL,132) Q:SCOUT
  1.  .S SCX="No patient position assignments found within selected report parameters!"
  1.  .W !!?(132-$L(SCX)\2),SCX
  1.  .Q
  1.  S SCPAGE=1
  1.  I SCFMT="D" S SCTITL(2)=$$HDRX("D") D HDR^SCRPO(.SCTITL,132),SHDR("D") Q:SCOUT  D
  1.  .S SC1=""
  1.  .F  S SC1=$O(^TMP("SCRPT",$J,1,SC1)) Q:SC1=""!SCOUT  D
  1.  ..S SC2=""
  1.  ..F  S SC2=$O(^TMP("SCRPT",$J,1,SC1,SC2)) Q:SC2=""!SCOUT  D
  1.  ...S SC3=""
  1.  ...F  S SC3=$O(^TMP("SCRPT",$J,1,SC1,SC2,SC3)) Q:SC3=""!SCOUT  D
  1.  ....S SCN=^TMP("SCRPT",$J,1,SC1,SC2,SC3),SC4=""
  1.  ....F  S SC4=$O(^TMP("SCRPT",$J,2,SCN,SC4)) Q:SC4=""!SCOUT  D
  1.  .....S SC5=""
  1.  .....F  S SC5=$O(^TMP("SCRPT",$J,2,SCN,SC4,SC5)) Q:SC5=""!SCOUT  D
  1.  ......S SC6=""
  1.  ......F  S SC6=$O(^TMP("SCRPT",$J,2,SCN,SC4,SC5,SC6)) Q:SC6=""!SCOUT  D
  1.  .......S SC7=""
  1.  .......F  S SC7=$O(^TMP("SCRPT",$J,2,SCN,SC4,SC5,SC6,SC7)) Q:SC7=""!SCOUT  D
  1.  ........S SCX=^TMP("SCRPT",$J,2,SCN,SC4,SC5,SC6,SC7)
  1.  ........;I $Y>(IOSL-9) D FOOT1,HDR^SCRPO(.SCTITL,132),SHDR("D") Q:SCOUT  ;IHS/ANMC/LJF 11/2/2000
  1.  ........I '$G(VALM),$Y>(IOSL-9) D FOOT1,HDR^SCRPO(.SCTITL,132),SHDR("D") Q:SCOUT  ;IHS/ANMC/LJF 11/2/2000
  1.  ........;S SCY="0^20^27^39^43^57^73^89^94^110^122" W !  ;IHS/ANMC/LJF 11/2/2000
  1.  ........S SCY="0^20^28^38^43^57^73^89^94^110^122" W !  ;IHS/ANMC/LJF 11/2/2000
  1.  ........F SCI=1:1:11 W ?($P(SCY,U,SCI)),$P(SCX,U,SCI)
  1.  .......Q
  1.  ......Q
  1.  .....Q
  1.  ....Q
  1.  ...Q
  1.  ..Q
  1.  .D:'SCOUT FOOT1
  1.  .Q
  1.  G:SCOUT EXIT
  1.  S SCTITL(2)=$$HDRX("S") D HDR^SCRPO(.SCTITL,132),SHDR("S") G:SCOUT EXIT
  1.  S SCASP=^TMP("SCRPT",$J,0,"ASSIGNMENTS")
  1.  ;F SCI="PRIMARY ELIGIBILITY","MEANS TEST CATEGORY","GENDER","AGE GROUP","NATIONAL ENROLLMENT PRIORITY","TEAM","PRIMARY CARE","ASSIGNED PROVIDER","PRECEPTOR PROVIDER","DIVISION" D  Q:SCOUT  ;IHS/ANMC/LJF 11/2/2000
  1.  F SCI="GENDER","AGE GROUP","TEAM","PRIMARY CARE","ASSIGNED PROVIDER","PRECEPTOR PROVIDER","DIVISION" D  Q:SCOUT  ;IHS/ANMC/LJF 11/2/2000
  1.  .Q:'$D(^TMP("SCRPT",$J,0,SCI))
  1.  .;D:$Y>(IOSL-9) FOOT2,HDR^SCRPO(.SCTITL,132),SHDR("S") Q:SCOUT  ;IHS/ANMC/LJF 11/2/2000
  1.  .I '$G(VALM) D:$Y>(IOSL-9) FOOT2,HDR^SCRPO(.SCTITL,132),SHDR("S") Q:SCOUT  ;IHS/ANMC/LJF 11/2/2000
  1.  .W ! D SLINE("--"_SCI_"--") S SCX=""
  1.  .F  S SCX=$O(^TMP("SCRPT",$J,0,SCI,SCX)) Q:SCX=""!SCOUT  D
  1.  ..S SCY=^TMP("SCRPT",$J,0,SCI,SCX)
  1.  ..S SCZ=SCY*100/SCASP
  1.  ..D:$Y>(IOSL-5) HDR^SCRPO(.SCTITL,132),SHDR("S") Q:SCOUT
  1.  ..D SLINE(SCX,SCY,SCZ)
  1.  ..Q
  1.  .Q
  1.  G:SCOUT EXIT
  1.  W ! D SLINE("Total assignments that meet the parameters of this report:",SCASP,100)
  1.  D SLINE("Total unique patients that meet the parameters of this report:",SCUNP,100)
  1.  D FOOT2
  1.  ;
  1. EXIT I $E(IOST)="C",'$G(SCOUT) N DIR S DIR(0)="E" D ^DIR
  1.  F SCI="SC","SCARR","SCRPT" K ^TMP(SCI,$J)
  1.  ;K SC D END^SCRPW50 Q  ;IHS/ANMC/LJF 11/2/2000
  1.  K SC Q     ;IHS/ANMC/LJF 11/2/2000 call to END^SCRPW50 in ^BSDSCO1
  1.  ;
  1. SLINE(SCX,SCY,SCZ) ;Print summary line
  1.  ;Input: SCX=element
  1.  ;Input: SCY=count
  1.  ;Input: SCZ=percent
  1.  ;
  1.  W !,$J($P(SCX,U),70) I $L($G(SCY)) W ?71,$J(SCY,10),?81,$J(SCZ,10,2)
  1.  Q
  1.  ;
  1. SHDR(SCX) ;Print report subheader
  1.  D SHDR^BSDSCO1(SCX) Q  ;IHS/ANMC/LJF 11/2/2000
  1.  ;Input: SCX='D' for detail, 'S' for summary
  1.  Q:SCOUT
  1.  I SCX="S" D  Q
  1.  .W !!?62,"Category",?76,"Count",?84,"Percent"
  1.  .W !?30,$E(SCLINE,1,40),"   --------  --------"
  1.  .Q
  1.  W !?20,"Pat.",?27,"Primary",?38,"MT",?94,"Enrolled",!,"Patient Name"
  1.  W ?20,"Id.",?27,"Elig.",?38,"Cat",?43,"Team",?57,"Provider"
  1.  W ?73,"Team Position",?89,"PC?",?94,"Clinic",?110,"Act. Date"
  1.  W ?122,"Inac. Date",!
  1.  W "------------------  -----  ---------  ---  ------------  --------------  --------------  ---  --------------  ----------  ----------"
  1.  Q
  1.  ;
  1. HDRX(SCX) ;extra header line
  1.  ;Input: SCX='P' for parameters, 'D' for detail, 'S' for summary
  1.  Q:SCX="P" "Selected Report Parameters"
  1.  Q $S(SCX="D":"Detail",1:"Summary")_" for Patient Position Assignments Effective: "_^TMP("SC",$J,"DTR","PBDT")_" to "_^TMP("SC",$J,"DTR","PEDT")
  1.  ;
  1. HINI ;Initialize header variables
  1.  N Y
  1.  S SCTITL(1)="<*>  HISTORICAL PATIENT POSITION ASSIGNMENT LISTING  <*>"
  1.  S SCLINE="",$P(SCLINE,"-",133)="",SCPAGE=1
  1.  S Y=$$NOW^XLFDT() X ^DD("DD") S SCPNOW=$P(Y,":",1,2)
  1.  Q
  1.  ;
  1. STOP ;Check for stop task request
  1.  S:$D(ZTQUEUED) (SCOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q
  1.  ;
  1. BUILD(SCFMT) ;Build report data
  1.  ;Input: SCFMT=report format (detail or summary)
  1.  N SCTM,SCTP
  1.  ;Build from position list
  1.  I $O(^TMP("SC",$J,"POS",0)) S SCTP=0 D  Q
  1.  .F  S SCTP=$O(^TMP("SC",$J,"POS",SCTP)) Q:'SCTP!SCOUT  D
  1.  ..D CKPOS(SCTP,SCFMT),STOP
  1.  ..Q
  1.  .Q
  1.  ;Build from all positions
  1.  S SCTP=0 F  S SCTP=$O(^SCTM(404.57,SCTP)) Q:'SCTP!SCOUT  D
  1.  .D CKPOS(SCTP,SCFMT),STOP
  1.  .Q
  1.  Q
  1.  ;
  1. CKPOS(SCTP,SCFMT) ;Check team position
  1.  ;Input: SCTP=TEAM POSITION ifn
  1.  ;Input: SCFMT=report format (detail or summary)
  1.  ;
  1.  N SCDIV,SCTEAM,SCPOS,SCLINIC,SCTP0,SCX
  1.  S SCTP0=$G(^SCTM(404.57,+SCTP,0)) Q:'$L(SCTP0)
  1.  S SCX=$P(SCTP0,U) Q:'$L(SCX)
  1.  S SCPOS=SCX_U_SCTP
  1.  S SCTEAM=$P(SCTP0,U,2) Q:'$$TMDV(.SCTEAM,.SCDIV)
  1.  S SCLINIC=$P(SCTP0,U,9) Q:'$$TPCL(.SCLINIC)
  1.  D BTPOS(SCTP,SCDIV,SCTEAM,SCPOS,SCLINIC,SCFMT)
  1.  Q
  1.  ;
  1. TPCL(SCLINIC) ;Get team position associated clinic
  1.  ;Input: SCLINIC=associated clinic pointer from team position
  1.  ;               (returned as name^ifn, if successful and one exists)
  1.  ;Output: '1' if success, '0' otherwise
  1.  ;
  1.  I $O(^TMP("SC",$J,"CLINIC",0)),'$D(^TMP("SC",$J,"CLINIC",+SCLINIC)) Q 0
  1.  Q:SCLINIC<1 1
  1.  S SCLINIC=$P($G(^SC(SCLINIC,0)),U)_U_SCLINIC
  1.  Q 1
  1.  ;
  1. TMDV(SCTEAM,SCDIV) ;Get team and division
  1.  ;Input: SCTEAM=team ifn (returned as name^ifn, if successful)
  1.  ;Input: SCDIV=variable to return division as name^ifn
  1.  ;Output: '1' if success, '0' otherwise
  1.  N SCTM0,SCX
  1.  Q:SCTEAM<1 0
  1.  I $O(^TMP("SC",$J,"TEAM",0)),'$D(^TMP("SC",$J,"TEAM",SCTEAM)) Q 0
  1.  S SCTM0=$G(^SCTM(404.51,SCTEAM,0)) Q:'$L(SCTM0) 0
  1.  S SCX=$P(SCTM0,U) Q:'$L(SCX) 0
  1.  S SCTEAM=SCX_U_SCTEAM
  1.  S SCDIV=$P(SCTM0,U,7) Q:SCDIV<1 0
  1.  I $O(^TMP("SC",$J,"DIV",0)),'$D(^TMP("SC",$J,"DIV",SCDIV)) Q 0
  1.  S SCX=$P($G(^DIC(4,SCDIV,0)),U) Q:'$L(SCX) 0
  1.  S SCDIV=SCX_U_SCDIV
  1.  Q 1
  1.  ;
  1. BTPOS(SCTP,SCDIV,SCTEAM,SCPOS,SCLINIC,SCFMT) ;Build list of patients for a position
  1.  ;Input: SCTP=team position ifn
  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.  N SCARR,SCDT,SCI,SCPASS
  1.  S SCARR="^TMP(""SCARR"",$J,1)" K @SCARR
  1.  M SCDT=^TMP("SC",$J,"DTR") S SCDT="SCDT"
  1.  S SCI=$$PTTP^SCAPMC(SCTP,.SCDT,SCARR),SCI=0
  1.  F  S SCI=$O(^TMP("SCARR",$J,1,SCI)) Q:'SCI  D
  1.  .S SCPASS=^TMP("SCARR",$J,1,SCI)
  1.  .D BPTPA^SCRPO2(SCPASS,SCDIV,SCTEAM,SCPOS,SCLINIC,SCFMT)
  1.  .Q
  1.  Q
  1.  ;
  1. FOOT1 ;Detail report footer
  1.  N SCI
  1.  F SCI=1:1:80 W ! Q:$Y>(IOSL-7)
  1.  W !,SCLINE
  1.  W !,"NOTE: More than one provider may be associated with a single patient position assignment.  This output returns a separate output"
  1.  W !?6,"line for each related provider during the date range selected."
  1.  W !!?6,"'PC?' represents provider type:  AP = Associate provider, PCP = Primary Care Provider, NPC = Non-Primary Care Provider."
  1.  W !,SCLINE
  1.  Q
  1.  ;
  1. FOOT2 ;Summary report footer
  1.  N SCI
  1.  F SCI=1:1:80 W ! Q:$Y>(IOSL-7)
  1.  W !,SCLINE
  1.  W !,"NOTE: More than one provider may be associated with a single patient position assignment.  The sum of assignments related to"
  1.  W !?6,"providers detailed in this summary is likely to be greater than the actual number of patient position assignments"
  1.  W !?6,"returned by this report."
  1.  W !,SCLINE
  1.  Q