- ACHSC6C ; IHS/ITSC/PMF - CALCULATE EXPENDITURE REPORT BY PATIENT/COMMUNITY ; [ 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))
- G ^ACHSC6P:ACHSTRDT<1!(ACHSTRDT>ACHSEDT),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))
- S 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 (ACHSTAO,ACHSP3B)=0
- I $G(^ACHSF(DUZ(2),"D",DOC,"PA"))>0 D
- .S ACHSTAO=+^ACHSF(DUZ(2),"D",DOC,"PA") S 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 ACHSTAO<1 S ACHSTAO=$P(X,U,9) G Z2:+ACHSTAO=0
- S ACHSTOS=$S(ACHSTY=1:43,ACHSTY=2:57,ACHSTY=3:64,1:"")
- S:ACHSTOS=64 ACHST64=ACHST64+ACHSTAO
- S:ACHSTOS=43 ACHST43=ACHST43+ACHSTAO
- S:ACHSTOS=57 ACHST57=ACHST57+ACHSTAO
- S ACHSESDA=$S($D(^ACHSF(DUZ(2),"D",DOC,1)):+$G(^ACHSF(DUZ(2),"D",DOC,1)),1:0),ACHSNAME=$P($G(^DPT(DFN,0)),U)
- COMM ; Community Of Residence.
- F ACHSCOMM=0:0 Q:'$O(^AUPNPAT(DFN,51,ACHSCOMM)) S ACHSCOMM=$O(^AUPNPAT(DFN,51,ACHSCOMM))
- S ACHSCOMM=$S(ACHSCOMM:$P($G(^AUPNPAT(DFN,51,ACHSCOMM,0)),U,3),1:"")
- S ACHSCOMN=""
- I ACHSCOMM,($D(^AUTTCOM(ACHSCOMM,0))#2) S ACHSCOMN=$P($G(^AUTTCOM(ACHSCOMM,0)),U)
- I ACHSCOMN="",($D(^AUPNPAT(DFN,11))#2) S ACHSCOMN=$P($G(^AUPNPAT(DFN,11)),U,18)
- S:ACHSCOMN="" ACHSCOMN="UNKNOWN"
- I ACHSRPT=2 S ACHSNAME=ACHSCOMN
- I ACHSRPT=5 S ACHSNAME=$P($G(^AUPNPAT(DFN,11)),U,8),ACHSNAME=$S(ACHSNAME:$P($G(^AUTTTRI(ACHSNAME,0)),U),1:"UNKNOWN")
- SET ; Set Work File.
- I '$D(^TMP("ACHSC6",$J,"P",ACHSNAME,ACHSTOS)) S ^TMP("ACHSC6",$J,"P",ACHSNAME,ACHSTOS)=DFN_U_ACHSCOMN_U_1_U_ACHSESDA_U_ACHSTAO_U_ACHSP3B G Z2
- S A=$P($G(^TMP("ACHSC6",$J,"P",ACHSNAME,ACHSTOS)),U,3)+1
- S B=$P($G(^TMP("ACHSC6",$J,"P",ACHSNAME,ACHSTOS)),U,4)+ACHSESDA
- S C=$P($G(^TMP("ACHSC6",$J,"P",ACHSNAME,ACHSTOS)),U,5)+ACHSTAO
- S D=$P($G(^TMP("ACHSC6",$J,"P",ACHSNAME,ACHSTOS)),U,6)+$S(ACHSTOS=57:ACHSTAO,1:0)
- S ^TMP("ACHSC6",$J,"P",ACHSNAME,ACHSTOS)=DFN_U_ACHSCOMN_U_A_U_B_U_C_U_D
- ;
- G Z2
- ;
- ACHSC6C ; IHS/ITSC/PMF - CALCULATE EXPENDITURE REPORT BY PATIENT/COMMUNITY ; [ 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)
- GOTO ^ACHSC6P
- IF '$DATA(^ACHSF(DUZ(2),"TB",ACHSTRDT,"I"))
- GOTO Z1
- +3 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
- +3 SET X=$GET(^ACHSF(DUZ(2),"D",DOC,0))
- +4 SET ACHSTY=$PIECE(X,U,4)
- +5 IF ACHSRPT1<4
- IF ACHSTY'=ACHSRPT1
- GOTO Z2
- +6 SET DFN=$PIECE(X,U,22)
- +7 IF DFN<1
- GOTO Z2
- IF '$DATA(^DPT(DFN,0))
- GOTO Z2
- +8 SET (ACHSTAO,ACHSP3B)=0
- +9 IF $GET(^ACHSF(DUZ(2),"D",DOC,"PA"))>0
- Begin DoDot:1
- +10 SET ACHSTAO=+^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)
- End DoDot:1
- +11 IF ACHSTAO<1
- SET ACHSTAO=$PIECE(X,U,9)
- IF +ACHSTAO=0
- GOTO Z2
- +12 SET ACHSTOS=$SELECT(ACHSTY=1:43,ACHSTY=2:57,ACHSTY=3:64,1:"")
- +13 IF ACHSTOS=64
- SET ACHST64=ACHST64+ACHSTAO
- +14 IF ACHSTOS=43
- SET ACHST43=ACHST43+ACHSTAO
- +15 IF ACHSTOS=57
- SET ACHST57=ACHST57+ACHSTAO
- +16 SET ACHSESDA=$SELECT($DATA(^ACHSF(DUZ(2),"D",DOC,1)):+$GET(^ACHSF(DUZ(2),"D",DOC,1)),1:0)
- SET ACHSNAME=$PIECE($GET(^DPT(DFN,0)),U)
- COMM ; Community Of Residence.
- +1 FOR ACHSCOMM=0:0
- IF '$ORDER(^AUPNPAT(DFN,51,ACHSCOMM))
- QUIT
- SET ACHSCOMM=$ORDER(^AUPNPAT(DFN,51,ACHSCOMM))
- +2 SET ACHSCOMM=$SELECT(ACHSCOMM:$PIECE($GET(^AUPNPAT(DFN,51,ACHSCOMM,0)),U,3),1:"")
- +3 SET ACHSCOMN=""
- +4 IF ACHSCOMM
- IF ($DATA(^AUTTCOM(ACHSCOMM,0))#2)
- SET ACHSCOMN=$PIECE($GET(^AUTTCOM(ACHSCOMM,0)),U)
- +5 IF ACHSCOMN=""
- IF ($DATA(^AUPNPAT(DFN,11))#2)
- SET ACHSCOMN=$PIECE($GET(^AUPNPAT(DFN,11)),U,18)
- +6 IF ACHSCOMN=""
- SET ACHSCOMN="UNKNOWN"
- +7 IF ACHSRPT=2
- SET ACHSNAME=ACHSCOMN
- +8 IF ACHSRPT=5
- SET ACHSNAME=$PIECE($GET(^AUPNPAT(DFN,11)),U,8)
- SET ACHSNAME=$SELECT(ACHSNAME:$PIECE($GET(^AUTTTRI(ACHSNAME,0)),U),1:"UNKNOWN")
- SET ; Set Work File.
- +1 IF '$DATA(^TMP("ACHSC6",$JOB,"P",ACHSNAME,ACHSTOS))
- SET ^TMP("ACHSC6",$JOB,"P",ACHSNAME,ACHSTOS)=DFN_U_ACHSCOMN_U_1_U_ACHSESDA_U_ACHSTAO_U_ACHSP3B
- GOTO Z2
- +2 SET A=$PIECE($GET(^TMP("ACHSC6",$JOB,"P",ACHSNAME,ACHSTOS)),U,3)+1
- +3 SET B=$PIECE($GET(^TMP("ACHSC6",$JOB,"P",ACHSNAME,ACHSTOS)),U,4)+ACHSESDA
- +4 SET C=$PIECE($GET(^TMP("ACHSC6",$JOB,"P",ACHSNAME,ACHSTOS)),U,5)+ACHSTAO
- +5 SET D=$PIECE($GET(^TMP("ACHSC6",$JOB,"P",ACHSNAME,ACHSTOS)),U,6)+$SELECT(ACHSTOS=57:ACHSTAO,1:0)
- +6 SET ^TMP("ACHSC6",$JOB,"P",ACHSNAME,ACHSTOS)=DFN_U_ACHSCOMN_U_A_U_B_U_C_U_D
- +7 ;
- +8 GOTO Z2
- +9 ;
