- 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 ;
