PXRMG2E2 ;SLC/JVS -GEC #2 EXTRACT #2 ;7/14/05 08:32
;;2.0;CLINICAL REMINDERS;**2,4**;Feb 04, 2005;Build 21
Q
;
;Variables
;CNTREF=The unique counted Referral number
;DA =DA or Ien of the Health Factor
;REF =REFERRAL NUMBER
;ARY =Array that is ordering through
Q
EN ;Entry Point
;SEND IN
;BDT,EDT,QUARTER
;-----TEMPORARY-----
;K ^TMP("PXRMGEC",$J)
;-----TEMPORARY-----
N CR1,CR2,CR3,CR4,CRITER,FOUND,CNT,ARY
N M1,M2,M3,BDTEDT
;---TEMPORARY
;S QUARTER=1
;---TEMORARY
S CRITER=0,FOUND=0,CNT=0
D PROGRAM^PXRMG2E4,CRITER4^PXRMG2E3
I $D(YEAR),$D(QUARTER) D
.S BDTEDT=$$FMDATE(YEAR,QUARTER)
.S BDT=$P(BDTEDT,"^",1)
.S EDT=$P(BDTEDT,"^",2)
;
D E^PXRMG2E1("HS",1,BDT,EDT,"F",DFNONLY,TPAT)
K VDOC
;This creates the following array besides the HS array
;TMP("PXRMGEC",$J,"GEC2",CNTREF,DA,AGE FLAG,APPOINTMENTS,MONTH)=""
;
S ARY="^TMP(""PXRMGEC"",$J,""GEC2"")"
S REF=0 F S REF=$O(@ARY@(REF)) Q:REF<1 D
.I QUARTER=1 S M1=1,M2=2,M3=3
.I QUARTER=2 S M1=4,M2=5,M3=6
.I QUARTER=3 S M1=7,M2=8,M3=9
.I QUARTER=4 S M1=10,M2=11,M3=12
.D PRE(REF)
D POST
Q
;======================================
FMDATE(YEAR,QUARTER) ;Get BDT and EDT from year and quarter
Q:YEAR=""
Q:QUARTER=""
Q:QUARTER>4
Q:QUARTER=0
N YER,QAR,BDT,EDT
S YER=YEAR-1700
I QUARTER=1 S BDT=YER_"0101",EDT=YER_"0331"
I QUARTER=2 S BDT=YER_"0401",EDT=YER_"0630"
I QUARTER=3 S BDT=YER_"0701",EDT=YER_"0930"
I QUARTER=4 S BDT=YER_"1001",EDT=YER_"1231"
Q BDT_"^"_EDT
;======================================
GET(REF) ;Get Criteria
N DFN,MONTH,NAME,SSN,PROG
S (CR1,CR2,CR3,CR4,CRITER)=0
S CR1=$$C1^PXRMG2S1(REF)
S CR2=$$C2^PXRMG2S1(REF)
S CR3=$$C3^PXRMG2S1(REF)
S CR4=$$C4^PXRMG2S1(REF)
S DFN=$P(CR4,"^",2)
S MONTH=$P(CR4,"^",3)
S NAME=$P(^DPT(DFN,0),"^",1)
S SSN=$P(CR4,"^",4)
S DATE=$P(CR4,"^",5)
S PROG=$P(CR4,"^",6)
S CR4=+CR4
I CR1=1 S CRITER="1"
I CR2=1 S CRITER=$S(CRITER=0:2,1:CRITER_",2")
I CR3=1 S CRITER=$S(CRITER=0:3,1:CRITER_",3")
I CR4=1 S CRITER=$S(CRITER=0:4,1:CRITER_",4")
S ^TMP("PXRMGEC",$J,"GEC2","RPT",NAME,SSN,DATE,CRITER,PROG)=""
Q CRITER
;
PRE(REF) ;Pre Process array by Program and Month
N ARY
S ARY="^TMP(""PXRMGEC"",$J,""GEC2"")"
I $D(@ARY@(REF,$O(P441(0)))),$D(@ARY@(REF,$O(P449(0)))) D
.S @ARY@("ADHC",$$MONTH(REF,ARY),REF,$$PIECE($$GET(REF)))=$$GET(REF)
I $D(@ARY@(REF,$O(P4410(0)))),$D(@ARY@(REF,$O(P449(0)))) D
.S @ARY@("HHHA",$$MONTH(REF,ARY),REF,$$PIECE($$GET(REF)))=$$GET(REF)
I $D(@ARY@(REF,$O(P4412(0)))),$D(@ARY@(REF,$O(P449(0)))) D
.S @ARY@("VAIHR",$$MONTH(REF,ARY),REF,$$PIECE($$GET(REF)))=$$GET(REF)
I $D(@ARY@(REF,$O(P451(0)))),$D(@ARY@(REF,$O(P452(0)))) D
.S @ARY@("CC",$$MONTH(REF,ARY),REF,$$PIECE($$GET(REF)))=$$GET(REF)
Q
;
MONTH(REF,ARY) ;Get month out of array
Q:REF=""
Q:ARY=""
N IEN,AGE,APP,DFN,MON
S IEN=$O(@ARY@(REF,0))
S AGE=$O(@ARY@(REF,IEN,-1))
S APP=$O(@ARY@(REF,IEN,AGE,-1))
S DFN=$O(@ARY@(REF,IEN,AGE,APP,0))
S MON=$O(@ARY@(REF,IEN,AGE,APP,DFN,0))
Q MON
;
PIECE(CRITER) ;Get the piece in the array the criter goes into
N PIECE
I CRITER=0 S PIECE=5
I CRITER=1 S PIECE=6
I CRITER=2 S PIECE=7
I CRITER=3 S PIECE=8
I CRITER=4 S PIECE=9
I CRITER="1,2" S PIECE=10
I CRITER="1,3" S PIECE=11
I CRITER="1,4" S PIECE=12
I CRITER="2,3" S PIECE=13
I CRITER="2,4" S PIECE=14
I CRITER="3,4" S PIECE=15
I CRITER="1,2,3" S PIECE=16
I CRITER="1,2,4" S PIECE=17
I CRITER="1,3,4" S PIECE=18
I CRITER="2,3,4" S PIECE=19
I CRITER="1,2,3,4" S PIECE=20
Q PIECE
;
POST ;Set the Statistical Arrays
D START
N PROG,MON,REF,PIE,MONX,SITE,STOP,ARY,X,Y
S ARY="^TMP(""PXRMGEC"",$J,""GEC2"")"
S PROG="ADH" F S PROG=$O(@ARY@(PROG)) Q:PROG="" D
.S MON=0 F S MON=$O(@ARY@(PROG,MON)) Q:MON="" D
..Q:MON'=M1&(MON'=M2)&(MON'=M3)
..S CNT=0
..S REF=0 F S REF=$O(@ARY@(PROG,MON,REF)) Q:REF="" D
...S CNT=CNT+1
...S PIE=0 F S PIE=$O(@ARY@(PROG,MON,REF,PIE)) Q:PIE="" D
....I MON=1!(MON=4)!(MON=7)!(MON=10) S MONX=1
....I MON=2!(MON=5)!(MON=8)!(MON=11) S MONX=2
....I MON=3!(MON=6)!(MON=9)!(MON=12) S MONX=3
....S Y=$P($G(STAT(PROG,MONX)),",",PIE)
....S Y=Y+1,$P(STAT(PROG,MONX),",",PIE)=Y
....S $P(STAT(PROG,MONX),",",2)=MON
....S $P(STAT(PROG,MONX),",",4)=CNT
Q
;
START ; Start the STAT(PROG,MON) ARRAYS
N I,SITE,F,S,T
I QUARTER=1 S F=1,S=2,T=3
I QUARTER=2 S F=4,S=5,T=6
I QUARTER=3 S F=7,S=8,T=9
I QUARTER=4 S F=10,S=11,T=12
S SITE=$P($$SITE^VASITE,"^",3)
F I=1:1:3 S STAT("ADHC",I)=SITE_",,"_"ADHC"_",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0" D
.I I=1 S $P(STAT("ADHC",I),",",2)=F
.I I=2 S $P(STAT("ADHC",I),",",2)=S
.I I=3 S $P(STAT("ADHC",I),",",2)=T
F I=1:1:3 S STAT("HHHA",I)=SITE_",,"_"HHHA"_",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0" D
.I I=1 S $P(STAT("HHHA",I),",",2)=F
.I I=2 S $P(STAT("HHHA",I),",",2)=S
.I I=3 S $P(STAT("HHHA",I),",",2)=T
F I=1:1:3 S STAT("CC",I)=SITE_",,"_"CC"_",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0" D
.I I=1 S $P(STAT("CC",I),",",2)=F
.I I=2 S $P(STAT("CC",I),",",2)=S
.I I=3 S $P(STAT("CC",I),",",2)=T
F I=1:1:3 S STAT("VAIHR",I)=SITE_",,"_"VAIHR"_",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0" D
.I I=1 S $P(STAT("VAIHR",I),",",2)=F
.I I=2 S $P(STAT("VAIHR",I),",",2)=S
.I I=3 S $P(STAT("VAIHR",I),",",2)=T
Q
WRITE ;Write to screen the STAT array
N PROG,MON
W !,"An Email containing this information will be sent to all those who are listed"
W !,"in the ""G.GEC2 NATIONAL ROLLUP"" mail group",!
S PROG="AD" F S PROG=$O(STAT(PROG)) Q:PROG="" D
.S MON=0 F S MON=$O(STAT(PROG,MON)) Q:MON="" D
..W !,$G(STAT(PROG,MON))
W !!,"The above information is a statistical compilation of the"
W !,"information seen in the local view of this option."
W !!,"Thanks in advance",!!
D MAIL^PXRMG2M1
D EXIT
Q
;=================================================
EXIT ;Exit and Clean up Variables
K C1101,C1107,C1108
K C1410,C1412,C1414,C142,C144,C146,C148,C166,C171
K C2110,C2114,C2118,C212,C2120,C214,C216,C218,C221,C224,C226
K C2710,C272,C274,C276,C278,C286
K P441,P4410,P4412,P449,P451,P452
K STAT
Q
PXRMG2E2 ;SLC/JVS -GEC #2 EXTRACT #2 ;7/14/05 08:32
+1 ;;2.0;CLINICAL REMINDERS;**2,4**;Feb 04, 2005;Build 21
+2 QUIT
+3 ;
+4 ;Variables
+5 ;CNTREF=The unique counted Referral number
+6 ;DA =DA or Ien of the Health Factor
+7 ;REF =REFERRAL NUMBER
+8 ;ARY =Array that is ordering through
+9 QUIT
EN ;Entry Point
+1 ;SEND IN
+2 ;BDT,EDT,QUARTER
+3 ;-----TEMPORARY-----
+4 ;K ^TMP("PXRMGEC",$J)
+5 ;-----TEMPORARY-----
+6 NEW CR1,CR2,CR3,CR4,CRITER,FOUND,CNT,ARY
+7 NEW M1,M2,M3,BDTEDT
+8 ;---TEMPORARY
+9 ;S QUARTER=1
+10 ;---TEMORARY
+11 SET CRITER=0
SET FOUND=0
SET CNT=0
+12 DO PROGRAM^PXRMG2E4
DO CRITER4^PXRMG2E3
+13 IF $DATA(YEAR)
IF $DATA(QUARTER)
Begin DoDot:1
+14 SET BDTEDT=$$FMDATE(YEAR,QUARTER)
+15 SET BDT=$PIECE(BDTEDT,"^",1)
+16 SET EDT=$PIECE(BDTEDT,"^",2)
End DoDot:1
+17 ;
+18 DO E^PXRMG2E1("HS",1,BDT,EDT,"F",DFNONLY,TPAT)
+19 KILL VDOC
+20 ;This creates the following array besides the HS array
+21 ;TMP("PXRMGEC",$J,"GEC2",CNTREF,DA,AGE FLAG,APPOINTMENTS,MONTH)=""
+22 ;
+23 SET ARY="^TMP(""PXRMGEC"",$J,""GEC2"")"
+24 SET REF=0
FOR
SET REF=$ORDER(@ARY@(REF))
IF REF<1
QUIT
Begin DoDot:1
+25 IF QUARTER=1
SET M1=1
SET M2=2
SET M3=3
+26 IF QUARTER=2
SET M1=4
SET M2=5
SET M3=6
+27 IF QUARTER=3
SET M1=7
SET M2=8
SET M3=9
+28 IF QUARTER=4
SET M1=10
SET M2=11
SET M3=12
+29 DO PRE(REF)
End DoDot:1
+30 DO POST
+31 QUIT
+32 ;======================================
FMDATE(YEAR,QUARTER) ;Get BDT and EDT from year and quarter
+1 IF YEAR=""
QUIT
+2 IF QUARTER=""
QUIT
+3 IF QUARTER>4
QUIT
+4 IF QUARTER=0
QUIT
+5 NEW YER,QAR,BDT,EDT
+6 SET YER=YEAR-1700
+7 IF QUARTER=1
SET BDT=YER_"0101"
SET EDT=YER_"0331"
+8 IF QUARTER=2
SET BDT=YER_"0401"
SET EDT=YER_"0630"
+9 IF QUARTER=3
SET BDT=YER_"0701"
SET EDT=YER_"0930"
+10 IF QUARTER=4
SET BDT=YER_"1001"
SET EDT=YER_"1231"
+11 QUIT BDT_"^"_EDT
+12 ;======================================
GET(REF) ;Get Criteria
+1 NEW DFN,MONTH,NAME,SSN,PROG
+2 SET (CR1,CR2,CR3,CR4,CRITER)=0
+3 SET CR1=$$C1^PXRMG2S1(REF)
+4 SET CR2=$$C2^PXRMG2S1(REF)
+5 SET CR3=$$C3^PXRMG2S1(REF)
+6 SET CR4=$$C4^PXRMG2S1(REF)
+7 SET DFN=$PIECE(CR4,"^",2)
+8 SET MONTH=$PIECE(CR4,"^",3)
+9 SET NAME=$PIECE(^DPT(DFN,0),"^",1)
+10 SET SSN=$PIECE(CR4,"^",4)
+11 SET DATE=$PIECE(CR4,"^",5)
+12 SET PROG=$PIECE(CR4,"^",6)
+13 SET CR4=+CR4
+14 IF CR1=1
SET CRITER="1"
+15 IF CR2=1
SET CRITER=$SELECT(CRITER=0:2,1:CRITER_",2")
+16 IF CR3=1
SET CRITER=$SELECT(CRITER=0:3,1:CRITER_",3")
+17 IF CR4=1
SET CRITER=$SELECT(CRITER=0:4,1:CRITER_",4")
+18 SET ^TMP("PXRMGEC",$JOB,"GEC2","RPT",NAME,SSN,DATE,CRITER,PROG)=""
+19 QUIT CRITER
+20 ;
PRE(REF) ;Pre Process array by Program and Month
+1 NEW ARY
+2 SET ARY="^TMP(""PXRMGEC"",$J,""GEC2"")"
+3 IF $DATA(@ARY@(REF,$ORDER(P441(0))))
IF $DATA(@ARY@(REF,$ORDER(P449(0))))
Begin DoDot:1
+4 SET @ARY@("ADHC",$$MONTH(REF,ARY),REF,$$PIECE($$GET(REF)))=$$GET(REF)
End DoDot:1
+5 IF $DATA(@ARY@(REF,$ORDER(P4410(0))))
IF $DATA(@ARY@(REF,$ORDER(P449(0))))
Begin DoDot:1
+6 SET @ARY@("HHHA",$$MONTH(REF,ARY),REF,$$PIECE($$GET(REF)))=$$GET(REF)
End DoDot:1
+7 IF $DATA(@ARY@(REF,$ORDER(P4412(0))))
IF $DATA(@ARY@(REF,$ORDER(P449(0))))
Begin DoDot:1
+8 SET @ARY@("VAIHR",$$MONTH(REF,ARY),REF,$$PIECE($$GET(REF)))=$$GET(REF)
End DoDot:1
+9 IF $DATA(@ARY@(REF,$ORDER(P451(0))))
IF $DATA(@ARY@(REF,$ORDER(P452(0))))
Begin DoDot:1
+10 SET @ARY@("CC",$$MONTH(REF,ARY),REF,$$PIECE($$GET(REF)))=$$GET(REF)
End DoDot:1
+11 QUIT
+12 ;
MONTH(REF,ARY) ;Get month out of array
+1 IF REF=""
QUIT
+2 IF ARY=""
QUIT
+3 NEW IEN,AGE,APP,DFN,MON
+4 SET IEN=$ORDER(@ARY@(REF,0))
+5 SET AGE=$ORDER(@ARY@(REF,IEN,-1))
+6 SET APP=$ORDER(@ARY@(REF,IEN,AGE,-1))
+7 SET DFN=$ORDER(@ARY@(REF,IEN,AGE,APP,0))
+8 SET MON=$ORDER(@ARY@(REF,IEN,AGE,APP,DFN,0))
+9 QUIT MON
+10 ;
PIECE(CRITER) ;Get the piece in the array the criter goes into
+1 NEW PIECE
+2 IF CRITER=0
SET PIECE=5
+3 IF CRITER=1
SET PIECE=6
+4 IF CRITER=2
SET PIECE=7
+5 IF CRITER=3
SET PIECE=8
+6 IF CRITER=4
SET PIECE=9
+7 IF CRITER="1,2"
SET PIECE=10
+8 IF CRITER="1,3"
SET PIECE=11
+9 IF CRITER="1,4"
SET PIECE=12
+10 IF CRITER="2,3"
SET PIECE=13
+11 IF CRITER="2,4"
SET PIECE=14
+12 IF CRITER="3,4"
SET PIECE=15
+13 IF CRITER="1,2,3"
SET PIECE=16
+14 IF CRITER="1,2,4"
SET PIECE=17
+15 IF CRITER="1,3,4"
SET PIECE=18
+16 IF CRITER="2,3,4"
SET PIECE=19
+17 IF CRITER="1,2,3,4"
SET PIECE=20
+18 QUIT PIECE
+19 ;
POST ;Set the Statistical Arrays
+1 DO START
+2 NEW PROG,MON,REF,PIE,MONX,SITE,STOP,ARY,X,Y
+3 SET ARY="^TMP(""PXRMGEC"",$J,""GEC2"")"
+4 SET PROG="ADH"
FOR
SET PROG=$ORDER(@ARY@(PROG))
IF PROG=""
QUIT
Begin DoDot:1
+5 SET MON=0
FOR
SET MON=$ORDER(@ARY@(PROG,MON))
IF MON=""
QUIT
Begin DoDot:2
+6 IF MON'=M1&(MON'=M2)&(MON'=M3)
QUIT
+7 SET CNT=0
+8 SET REF=0
FOR
SET REF=$ORDER(@ARY@(PROG,MON,REF))
IF REF=""
QUIT
Begin DoDot:3
+9 SET CNT=CNT+1
+10 SET PIE=0
FOR
SET PIE=$ORDER(@ARY@(PROG,MON,REF,PIE))
IF PIE=""
QUIT
Begin DoDot:4
+11 IF MON=1!(MON=4)!(MON=7)!(MON=10)
SET MONX=1
+12 IF MON=2!(MON=5)!(MON=8)!(MON=11)
SET MONX=2
+13 IF MON=3!(MON=6)!(MON=9)!(MON=12)
SET MONX=3
+14 SET Y=$PIECE($GET(STAT(PROG,MONX)),",",PIE)
+15 SET Y=Y+1
SET $PIECE(STAT(PROG,MONX),",",PIE)=Y
+16 SET $PIECE(STAT(PROG,MONX),",",2)=MON
+17 SET $PIECE(STAT(PROG,MONX),",",4)=CNT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
START ; Start the STAT(PROG,MON) ARRAYS
+1 NEW I,SITE,F,S,T
+2 IF QUARTER=1
SET F=1
SET S=2
SET T=3
+3 IF QUARTER=2
SET F=4
SET S=5
SET T=6
+4 IF QUARTER=3
SET F=7
SET S=8
SET T=9
+5 IF QUARTER=4
SET F=10
SET S=11
SET T=12
+6 SET SITE=$PIECE($$SITE^VASITE,"^",3)
+7 FOR I=1:1:3
SET STAT("ADHC",I)=SITE_",,"_"ADHC"_",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0"
Begin DoDot:1
+8 IF I=1
SET $PIECE(STAT("ADHC",I),",",2)=F
+9 IF I=2
SET $PIECE(STAT("ADHC",I),",",2)=S
+10 IF I=3
SET $PIECE(STAT("ADHC",I),",",2)=T
End DoDot:1
+11 FOR I=1:1:3
SET STAT("HHHA",I)=SITE_",,"_"HHHA"_",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0"
Begin DoDot:1
+12 IF I=1
SET $PIECE(STAT("HHHA",I),",",2)=F
+13 IF I=2
SET $PIECE(STAT("HHHA",I),",",2)=S
+14 IF I=3
SET $PIECE(STAT("HHHA",I),",",2)=T
End DoDot:1
+15 FOR I=1:1:3
SET STAT("CC",I)=SITE_",,"_"CC"_",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0"
Begin DoDot:1
+16 IF I=1
SET $PIECE(STAT("CC",I),",",2)=F
+17 IF I=2
SET $PIECE(STAT("CC",I),",",2)=S
+18 IF I=3
SET $PIECE(STAT("CC",I),",",2)=T
End DoDot:1
+19 FOR I=1:1:3
SET STAT("VAIHR",I)=SITE_",,"_"VAIHR"_",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0"
Begin DoDot:1
+20 IF I=1
SET $PIECE(STAT("VAIHR",I),",",2)=F
+21 IF I=2
SET $PIECE(STAT("VAIHR",I),",",2)=S
+22 IF I=3
SET $PIECE(STAT("VAIHR",I),",",2)=T
End DoDot:1
+23 QUIT
WRITE ;Write to screen the STAT array
+1 NEW PROG,MON
+2 WRITE !,"An Email containing this information will be sent to all those who are listed"
+3 WRITE !,"in the ""G.GEC2 NATIONAL ROLLUP"" mail group",!
+4 SET PROG="AD"
FOR
SET PROG=$ORDER(STAT(PROG))
IF PROG=""
QUIT
Begin DoDot:1
+5 SET MON=0
FOR
SET MON=$ORDER(STAT(PROG,MON))
IF MON=""
QUIT
Begin DoDot:2
+6 WRITE !,$GET(STAT(PROG,MON))
End DoDot:2
End DoDot:1
+7 WRITE !!,"The above information is a statistical compilation of the"
+8 WRITE !,"information seen in the local view of this option."
+9 WRITE !!,"Thanks in advance",!!
+10 DO MAIL^PXRMG2M1
+11 DO EXIT
+12 QUIT
+13 ;=================================================
EXIT ;Exit and Clean up Variables
+1 KILL C1101,C1107,C1108
+2 KILL C1410,C1412,C1414,C142,C144,C146,C148,C166,C171
+3 KILL C2110,C2114,C2118,C212,C2120,C214,C216,C218,C221,C224,C226
+4 KILL C2710,C272,C274,C276,C278,C286
+5 KILL P441,P4410,P4412,P449,P451,P452
+6 KILL STAT
+7 QUIT
