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