ACHSC6D ; IHS/ITSC/PMF - CALCULATE EXPENDITURE REPORT BY AGE GROUP ; [ 10/16/2001 8:16 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
;
ST ;
D NOW^ACHS
K ^TMP("ACHSC6",$J)
Z ;
S ACHSTRDT=ACHSBDT-1,(ACHST64,ACHST43,ACHST57)=0
Z1 ;
S ACHSTRDT=$O(^ACHSF(DUZ(2),"TB",ACHSTRDT))
I ACHSTRDT<1!(ACHSTRDT>ACHSEDT) G ^ACHSC6P:ACHSRPT<3,^ACHSC6P1
G Z1:'$D(^ACHSF(DUZ(2),"TB",ACHSTRDT,"I"))
S DOC=0
Z2 ;
S DOC=$O(^ACHSF(DUZ(2),"TB",ACHSTRDT,"I",DOC))
G Z1:DOC<1,Z2:'$D(^ACHSF(DUZ(2),"D",DOC,0)) S X=$G(^ACHSF(DUZ(2),"D",DOC,0)),ACHSTY=$P(X,U,4)
I ACHSRPT1<4,ACHSTY'=ACHSRPT1 G Z2
S DFN=$P(X,U,22)
G Z2:DFN<1,Z2:'$D(^DPT(DFN,0))
S (ACHSTOT,ACHSTOA,ACHSP3B,ACHSESDA,ACHST43,ACHSWKL,ACHST64,ACHST57)=0
I $G(^ACHSF(DUZ(2),"D",DOC,"PA"))>0 S ACHSTOA=+$G(^ACHSF(DUZ(2),"D",DOC,"PA")),ACHS=0 F S ACHS=$O(^ACHSF(DUZ(2),"D",DOC,"T",ACHS)) Q:+ACHS=0 S ACHSP3B=ACHSP3B+$P($G(^ACHSF(DUZ(2),"D",DOC,"T",ACHS,0)),U,8)
I ACHSTOA<1 S ACHSTOA=$P(X,U,9) G Z2:+ACHSTOA=0
S ACHSTOS=$S(ACHSTY=1:43,ACHSTY=2:57,ACHSTY=3:64,1:"")
S:ACHSTOS=64 ACHST64=ACHST64+ACHSTOA
S:ACHSTOS=43 ACHST43=ACHST43+ACHSTOA
S:ACHSTOS=57 ACHST57=ACHST57+ACHSTOA
S ACHSESDA=$S($D(^ACHSF(DUZ(2),"D",DOC,1)):+$G(^ACHSF(DUZ(2),"D",DOC,1)),1:0)
S ACHSNAME=$P($G(^DPT(DFN,0)),U)
S ACHSSEX=$P($G(^DPT(DFN,0)),U,2)
S X2=$P($G(^DPT(DFN,0)),U,3),X1=DT,X=""
D ^%DTC
S X=X\365.25
S ACHSGRP=$S(+X<1:"A",+X>0&(+X<5):"B",+X>4&(+X<10):"C",+X>9&(+X<15):"D",+X>14&(+X<20):"E",+X>19&(+X<25):"F",+X>24&(+X<30):"G",+X>29&(+X<40):"H",+X>39&(+X<55):"I",+X>54&(+X<65):"J",1:"K")
SET ; Set Work Global.
S (B,E,H)=0,ACHSTOT=ACHSP3B+ACHSTOA
S:ACHSTOS=43 B=1
S:ACHSTOS=64 E=1
S:ACHSTOS=57 H=1
I '$D(^TMP("ACHSC6",$J,"P",ACHSGRP,ACHSSEX)) S ^(ACHSSEX)=1_U_B_U_ACHSESDA_U_ACHST43_U_E_U_ACHSWKL_U_ACHST64_U_H_U_ACHST57_U_ACHSTOA_U_ACHSP3B_U_ACHSTOT G Z2
S X=$G(^TMP("ACHSC6",$J,"P",ACHSGRP,ACHSSEX)),B=$P(X,U,2),E=$P(X,U,5),H=$P(X,U,8)
S A=$P(X,U)+1
S:ACHSTOS=43 B=$P(X,U,2)+1
S C=$P(X,U,3)+ACHSESDA,D=$P(X,U,4)+ACHST43
S:ACHSTOS=64 E=$P(X,U,5)+1
S F=$P(X,U,6)+ACHSWKL,G=$P(X,U,7)+ACHST64
S:ACHSTOS=57 H=$P(X,U,8)+1
S I=$P(X,U,9)+ACHST57,ACHSTOAA=$P(X,U,10)+ACHST43+ACHST64+ACHST57
S ACHST3P=$P(X,U,11)+ACHSP3B S ACHSTOTT=$P(X,U,12)+ACHSTOT
S ^TMP("ACHSC6",$J,"P",ACHSGRP,ACHSSEX)=A_U_B_U_C_U_D_U_E_U_F_U_G_U_H_U_I_U_ACHSTOAA_U_ACHST3P_U_ACHSTOTT
G Z2
;
ACHSC6D ; IHS/ITSC/PMF - CALCULATE EXPENDITURE REPORT BY AGE GROUP ; [ 10/16/2001 8:16 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
+2 ;
ST ;
+1 DO NOW^ACHS
+2 KILL ^TMP("ACHSC6",$JOB)
Z ;
+1 SET ACHSTRDT=ACHSBDT-1
SET (ACHST64,ACHST43,ACHST57)=0
Z1 ;
+1 SET ACHSTRDT=$ORDER(^ACHSF(DUZ(2),"TB",ACHSTRDT))
+2 IF ACHSTRDT<1!(ACHSTRDT>ACHSEDT)
IF ACHSRPT<3
GOTO ^ACHSC6P
GOTO ^ACHSC6P1
+3 IF '$DATA(^ACHSF(DUZ(2),"TB",ACHSTRDT,"I"))
GOTO Z1
+4 SET DOC=0
Z2 ;
+1 SET DOC=$ORDER(^ACHSF(DUZ(2),"TB",ACHSTRDT,"I",DOC))
+2 IF DOC<1
GOTO Z1
IF '$DATA(^ACHSF(DUZ(2),"D",DOC,0))
GOTO Z2
SET X=$GET(^ACHSF(DUZ(2),"D",DOC,0))
SET ACHSTY=$PIECE(X,U,4)
+3 IF ACHSRPT1<4
IF ACHSTY'=ACHSRPT1
GOTO Z2
+4 SET DFN=$PIECE(X,U,22)
+5 IF DFN<1
GOTO Z2
IF '$DATA(^DPT(DFN,0))
GOTO Z2
+6 SET (ACHSTOT,ACHSTOA,ACHSP3B,ACHSESDA,ACHST43,ACHSWKL,ACHST64,ACHST57)=0
+7 IF $GET(^ACHSF(DUZ(2),"D",DOC,"PA"))>0
SET ACHSTOA=+$GET(^ACHSF(DUZ(2),"D",DOC,"PA"))
SET ACHS=0
FOR
SET ACHS=$ORDER(^ACHSF(DUZ(2),"D",DOC,"T",ACHS))
IF +ACHS=0
QUIT
SET ACHSP3B=ACHSP3B+$PIECE($GET(^ACHSF(DUZ(2),"D",DOC,"T",ACHS,0)),U,8)
+8 IF ACHSTOA<1
SET ACHSTOA=$PIECE(X,U,9)
IF +ACHSTOA=0
GOTO Z2
+9 SET ACHSTOS=$SELECT(ACHSTY=1:43,ACHSTY=2:57,ACHSTY=3:64,1:"")
+10 IF ACHSTOS=64
SET ACHST64=ACHST64+ACHSTOA
+11 IF ACHSTOS=43
SET ACHST43=ACHST43+ACHSTOA
+12 IF ACHSTOS=57
SET ACHST57=ACHST57+ACHSTOA
+13 SET ACHSESDA=$SELECT($DATA(^ACHSF(DUZ(2),"D",DOC,1)):+$GET(^ACHSF(DUZ(2),"D",DOC,1)),1:0)
+14 SET ACHSNAME=$PIECE($GET(^DPT(DFN,0)),U)
+15 SET ACHSSEX=$PIECE($GET(^DPT(DFN,0)),U,2)
+16 SET X2=$PIECE($GET(^DPT(DFN,0)),U,3)
SET X1=DT
SET X=""
+17 DO ^%DTC
+18 SET X=X\365.25
+19 SET ACHSGRP=$SELECT(+X<1:"A",+X>0&(+X<5):"B",+X>4&(+X<10):"C",+X>9&(+X<15):"D",+X>14&(+X<20):"E",+X>19&(+X<25):"F",+X>24&(+X<30):"G",+X>29&(+X<40):"H",+X>39&(+X<55):"I",+X>54&(+X<65):"J",1:"K")
SET ; Set Work Global.
+1 SET (B,E,H)=0
SET ACHSTOT=ACHSP3B+ACHSTOA
+2 IF ACHSTOS=43
SET B=1
+3 IF ACHSTOS=64
SET E=1
+4 IF ACHSTOS=57
SET H=1
+5 IF '$DATA(^TMP("ACHSC6",$JOB,"P",ACHSGRP,ACHSSEX))
SET ^(ACHSSEX)=1_U_B_U_ACHSESDA_U_ACHST43_U_E_U_ACHSWKL_U_ACHST64_U_H_U_ACHST57_U_ACHSTOA_U_ACHSP3B_U_ACHSTOT
GOTO Z2
+6 SET X=$GET(^TMP("ACHSC6",$JOB,"P",ACHSGRP,ACHSSEX))
SET B=$PIECE(X,U,2)
SET E=$PIECE(X,U,5)
SET H=$PIECE(X,U,8)
+7 SET A=$PIECE(X,U)+1
+8 IF ACHSTOS=43
SET B=$PIECE(X,U,2)+1
+9 SET C=$PIECE(X,U,3)+ACHSESDA
SET D=$PIECE(X,U,4)+ACHST43
+10 IF ACHSTOS=64
SET E=$PIECE(X,U,5)+1
+11 SET F=$PIECE(X,U,6)+ACHSWKL
SET G=$PIECE(X,U,7)+ACHST64
+12 IF ACHSTOS=57
SET H=$PIECE(X,U,8)+1
+13 SET I=$PIECE(X,U,9)+ACHST57
SET ACHSTOAA=$PIECE(X,U,10)+ACHST43+ACHST64+ACHST57
+14 SET ACHST3P=$PIECE(X,U,11)+ACHSP3B
SET ACHSTOTT=$PIECE(X,U,12)+ACHSTOT
+15 SET ^TMP("ACHSC6",$JOB,"P",ACHSGRP,ACHSSEX)=A_U_B_U_C_U_D_U_E_U_F_U_G_U_H_U_I_U_ACHSTOAA_U_ACHST3P_U_ACHSTOTT
+16 GOTO Z2
+17 ;
