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 ;
