ACHSODB ; IHS/ITSC/PMF - BUILD DCR REPORT FILE ; [ 10/16/2001 8:16 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
;
G A7:'$D(^TMP("ACHSOD",$J,DUZ(2),0))
S ACHSZYR=0,ACHSZYR=$O(^TMP("ACHSOD",$J,DUZ(2),"DCR",ACHSZYR)) G A7:+ACHSZYR<1980 S X=$G(^TMP("ACHSOD",$J,DUZ(2),"DCR",ACHSZYR,0))
D FY^ACHSUF
S ACHSACFY=0
A0 ;
S ACHSACFY=$O(^TMP("ACHSOD",$J,DUZ(2),"DCR",ACHSACFY))
G A7:+ACHSACFY=0
S X=$G(^TMP("ACHSOD",$J,DUZ(2),"DCR",ACHSACFY,0))
S ^TMP("ACHSOD",$J,DUZ(2),"TRAN",ACHSACFY)=0
S ^TMP("ACHSOD",$J,DUZ(2),"TOTAL",ACHSACFY)=0
S ACHSIO=$P(X,U,2),ACHSBDT=$P(X,U,3),ACHSEDT=$P(X,U,4),ACHSACFY=$P(X,U,5),ACHSDCR=$P(X,U,6),ACHSACY=$E(ACHSACFY,4)
S ACHSTRDT=ACHSBDT
A1 ;
S ACHSTRDT=$O(^ACHSF(DUZ(2),"TB",ACHSTRDT))
G A0:ACHSTRDT>ACHSEDT,A0:ACHSTRDT=""
S ACHSACT1=""
A2 ;
S ACHSACT1=$O(^ACHSF(DUZ(2),"TB",ACHSTRDT,ACHSACT1))
G A1:ACHSACT1=""
S ACHSDIEN=""
A3 ;
S ACHSDIEN=$O(^ACHSF(DUZ(2),"TB",ACHSTRDT,ACHSACT1,ACHSDIEN))
G A2:ACHSDIEN=""
S ACHSACN=""
G A3:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,0)) S ACHSDOCR=^(0)
I ACHSDCR,$P(ACHSDOCR,U,14)'=ACHSACY G A3
S ACHSDEST=$P(ACHSDOCR,U,17)
S:ACHSDEST="" ACHSDEST="I"
K ACHSBLKF
I $D(^ACHSF(DUZ(2),"D",ACHSDIEN,"BT")) S ACHSBLKF=""
S R=+$P(ACHSDOCR,U,19),ACHSADS=ACHSTRDT_U_$P(ACHSDIEN,U)_U_R_U_$P(ACHSDOCR,U,8)_U
A4 ;
S ACHSACN=$O(^ACHSF(DUZ(2),"TB",ACHSTRDT,ACHSACT1,ACHSDIEN,ACHSACN))
G A3:ACHSACN="",A4:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSACN,0))
S (X,T)=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSACN,0)),U,2)
S DFN=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSACN,0)),U,3)
S Y=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSACN,0)),U,5)
S (A,O)=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSACN,0)),U,4)
S ACHSDOS=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSACN,0)),U,10)
S ACHSACD=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,0)),U),ACHSSET=0
I X="C",Y="P" S T="D"
I T'="P" S A=0 G A5
G A6:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA"))
S O=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")),A=$P(O,U,6),O=$P(O,U,2)
;
A5 ;
S ACHSTS=DFN_U_T_U_O_U_A_U_ACHSDOS,ACHSSET=1
S:'$D(^TMP("ACHSOD",$J,DUZ(2),"DHR",ACHSACFY)) ^TMP("ACHSOD",$J,DUZ(2),"DHR",ACHSACFY)=0
I T="S",ACHSDEST'="I" G A6
I T="D",ACHSDEST'="I" G A6
I T="ZA" G A6
I T="IP" G A6
I T="P" G A6
I +$P(ACHSDOCR,U,3)=2 G A6
S ^TMP("ACHSOD",$J,DUZ(2),"DHR",ACHSACFY)=^TMP("ACHSOD",$J,DUZ(2),"DHR",ACHSACFY)+1
A6 ;
S ACHSTY=ACHSACT1
;
I ACHSSET D
. S ^TMP("ACHSOD",$J,DUZ(2),ACHSACFY,ACHSACD,ACHSDIEN,ACHSACN)=ACHSADS_ACHSTS
. S:ACHSTY="C" O="-"_O D ;IF ITS A CANCEL NEGATE
. S ^TMP("ACHSOD",$J,DUZ(2),"TRAN",ACHSACFY)=^TMP("ACHSOD",$J,DUZ(2),"TRAN",ACHSACFY)+1
. S ^TMP("ACHSOD",$J,DUZ(2),"TOTAL",ACHSACFY)=^TMP("ACHSOD",$J,DUZ(2),"TOTAL",ACHSACFY)+O
;
;
S ACHSTY=$S(ACHSTY="I":"INITIAL",ACHSTY="P":"PAYMENTS",ACHSTY="S":"SUPPLEMENTS",ACHSTY="C":"CANCEL",ACHSTY="ZA":"ADJUSTMENT",ACHSTY="IP":"INTERIM PAYMENTS",1:"UNKNOWN")
;
I ACHSSET,$D(ACHSTY) D
.S:'$D(^TMP("ACHSOD",$J,DUZ(2),ACHSTY,ACHSACFY)) ^TMP("ACHSOD",$J,DUZ(2),ACHSTY,ACHSACFY)=0 S X=^TMP("ACHSOD",$J,DUZ(2),ACHSTY,ACHSACFY)
.S $P(X,U)=$P(X,U)+1
.S $P(X,U,2)=$P(X,U,2)+O
.S ^TMP("ACHSOD",$J,DUZ(2),ACHSTY,ACHSACFY)=X
;
;SET THE FISCAL INTERMEDIARY
S ACHSFI=$S(ACHSDEST="I":"IHS",1:"FISCAL AGENT")
S:'$D(^TMP("ACHSOD",$J,DUZ(2),ACHSFI,ACHSACFY)) ^TMP("ACHSOD",$J,DUZ(2),ACHSFI,ACHSACFY)=0
S ^TMP("ACHSOD",$J,DUZ(2),ACHSFI,ACHSACFY)=^TMP("ACHSOD",$J,DUZ(2),ACHSFI,ACHSACFY)+1
G A4
;
A7 ;
S F=0,B=9999998-ACHSBDT
REGCHECK ;
S F=$O(^TMP("ACHSOD",$J,DUZ(2),F)),R="",W=0
G END:F<1
S N=$O(^ACHS(9,DUZ(2),"FY",F,"AR",B)) I N]"" S W=$O(^(N,0)) I W,$D(^ACHS(9,DUZ(2),"FY",F,"W",W,1)) S R=$G(^ACHS(9,DUZ(2),"FY",F,"W",W,1))
I 'ACHSDCR,F'=ACHSCFY D CLSOPEN
G REGCHECK
;
END ;
K ACHSDCR,ACHSTRDT,ACHSACY,ACHSDEST,ACHSDOCR,ACHSFI,ACHSZYR
G ^ACHSODP
;
CLSOPEN ;
;12/27/00 pmf remove naked refs
S $P(^ACHS(9,DUZ(2),"FY",F,"W",W,0),U,2)=ACHSEDT
S R=$G(^ACHS(9,DUZ(2),"FY",F,"W",W,1))
S ^ACHS(9,DUZ(2),"FY",F,"AR",9999999-ACHSEDT,W)=""
;
NEWREG ;
S W=W+1
I $D(^ACHS(9,DUZ(2),"FY",F,"W",W)) G NEWREG
S ^ACHS(9,DUZ(2),"FY",F,"W",W,0)=W
S ^ACHS(9,DUZ(2),"FY",F,"W",W,1)=R,X="^9002069.02^"
I $D(^ACHS(9,DUZ(2),"FY",F,"W",0)) S X=$G(^ACHS(9,DUZ(2),"FY",F,"W",0))
S $P(X,U,3)=W,$P(X,U,4)=$P(X,U,4)+1,^ACHS(9,DUZ(2),"FY",F,"W",0)=X
Q
;
ACHSODB ; IHS/ITSC/PMF - BUILD DCR REPORT FILE ; [ 10/16/2001 8:16 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
+2 ;
+3 IF '$DATA(^TMP("ACHSOD",$JOB,DUZ(2),0))
GOTO A7
+4 SET ACHSZYR=0
SET ACHSZYR=$ORDER(^TMP("ACHSOD",$JOB,DUZ(2),"DCR",ACHSZYR))
IF +ACHSZYR<1980
GOTO A7
SET X=$GET(^TMP("ACHSOD",$JOB,DUZ(2),"DCR",ACHSZYR,0))
+5 DO FY^ACHSUF
+6 SET ACHSACFY=0
A0 ;
+1 SET ACHSACFY=$ORDER(^TMP("ACHSOD",$JOB,DUZ(2),"DCR",ACHSACFY))
+2 IF +ACHSACFY=0
GOTO A7
+3 SET X=$GET(^TMP("ACHSOD",$JOB,DUZ(2),"DCR",ACHSACFY,0))
+4 SET ^TMP("ACHSOD",$JOB,DUZ(2),"TRAN",ACHSACFY)=0
+5 SET ^TMP("ACHSOD",$JOB,DUZ(2),"TOTAL",ACHSACFY)=0
+6 SET ACHSIO=$PIECE(X,U,2)
SET ACHSBDT=$PIECE(X,U,3)
SET ACHSEDT=$PIECE(X,U,4)
SET ACHSACFY=$PIECE(X,U,5)
SET ACHSDCR=$PIECE(X,U,6)
SET ACHSACY=$EXTRACT(ACHSACFY,4)
+7 SET ACHSTRDT=ACHSBDT
A1 ;
+1 SET ACHSTRDT=$ORDER(^ACHSF(DUZ(2),"TB",ACHSTRDT))
+2 IF ACHSTRDT>ACHSEDT
GOTO A0
IF ACHSTRDT=""
GOTO A0
+3 SET ACHSACT1=""
A2 ;
+1 SET ACHSACT1=$ORDER(^ACHSF(DUZ(2),"TB",ACHSTRDT,ACHSACT1))
+2 IF ACHSACT1=""
GOTO A1
+3 SET ACHSDIEN=""
A3 ;
+1 SET ACHSDIEN=$ORDER(^ACHSF(DUZ(2),"TB",ACHSTRDT,ACHSACT1,ACHSDIEN))
+2 IF ACHSDIEN=""
GOTO A2
+3 SET ACHSACN=""
+4 IF '$DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,0))
GOTO A3
SET ACHSDOCR=^(0)
+5 IF ACHSDCR
IF $PIECE(ACHSDOCR,U,14)'=ACHSACY
GOTO A3
+6 SET ACHSDEST=$PIECE(ACHSDOCR,U,17)
+7 IF ACHSDEST=""
SET ACHSDEST="I"
+8 KILL ACHSBLKF
+9 IF $DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,"BT"))
SET ACHSBLKF=""
+10 SET R=+$PIECE(ACHSDOCR,U,19)
SET ACHSADS=ACHSTRDT_U_$PIECE(ACHSDIEN,U)_U_R_U_$PIECE(ACHSDOCR,U,8)_U
A4 ;
+1 SET ACHSACN=$ORDER(^ACHSF(DUZ(2),"TB",ACHSTRDT,ACHSACT1,ACHSDIEN,ACHSACN))
+2 IF ACHSACN=""
GOTO A3
IF '$DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSACN,0))
GOTO A4
+3 SET (X,T)=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSACN,0)),U,2)
+4 SET DFN=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSACN,0)),U,3)
+5 SET Y=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSACN,0)),U,5)
+6 SET (A,O)=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSACN,0)),U,4)
+7 SET ACHSDOS=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSACN,0)),U,10)
+8 SET ACHSACD=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,0)),U)
SET ACHSSET=0
+9 IF X="C"
IF Y="P"
SET T="D"
+10 IF T'="P"
SET A=0
GOTO A5
+11 IF '$DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA"))
GOTO A6
+12 SET O=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA"))
SET A=$PIECE(O,U,6)
SET O=$PIECE(O,U,2)
+13 ;
A5 ;
+1 SET ACHSTS=DFN_U_T_U_O_U_A_U_ACHSDOS
SET ACHSSET=1
+2 IF '$DATA(^TMP("ACHSOD",$JOB,DUZ(2),"DHR",ACHSACFY))
SET ^TMP("ACHSOD",$JOB,DUZ(2),"DHR",ACHSACFY)=0
+3 IF T="S"
IF ACHSDEST'="I"
GOTO A6
+4 IF T="D"
IF ACHSDEST'="I"
GOTO A6
+5 IF T="ZA"
GOTO A6
+6 IF T="IP"
GOTO A6
+7 IF T="P"
GOTO A6
+8 IF +$PIECE(ACHSDOCR,U,3)=2
GOTO A6
+9 SET ^TMP("ACHSOD",$JOB,DUZ(2),"DHR",ACHSACFY)=^TMP("ACHSOD",$JOB,DUZ(2),"DHR",ACHSACFY)+1
A6 ;
+1 SET ACHSTY=ACHSACT1
+2 ;
+3 IF ACHSSET
Begin DoDot:1
+4 SET ^TMP("ACHSOD",$JOB,DUZ(2),ACHSACFY,ACHSACD,ACHSDIEN,ACHSACN)=ACHSADS_ACHSTS
+5 ;IF ITS A CANCEL NEGATE
IF ACHSTY="C"
SET O="-"_O
Begin DoDot:2
End DoDot:2
+6 SET ^TMP("ACHSOD",$JOB,DUZ(2),"TRAN",ACHSACFY)=^TMP("ACHSOD",$JOB,DUZ(2),"TRAN",ACHSACFY)+1
+7 SET ^TMP("ACHSOD",$JOB,DUZ(2),"TOTAL",ACHSACFY)=^TMP("ACHSOD",$JOB,DUZ(2),"TOTAL",ACHSACFY)+O
End DoDot:1
+8 ;
+9 ;
+10 SET ACHSTY=$SELECT(ACHSTY="I":"INITIAL",ACHSTY="P":"PAYMENTS",ACHSTY="S":"SUPPLEMENTS",ACHSTY="C":"CANCEL",ACHSTY="ZA":"ADJUSTMENT",ACHSTY="IP":"INTERIM PAYMENTS",1:"UNKNOWN")
+11 ;
+12 IF ACHSSET
IF $DATA(ACHSTY)
Begin DoDot:1
+13 IF '$DATA(^TMP("ACHSOD",$JOB,DUZ(2),ACHSTY,ACHSACFY))
SET ^TMP("ACHSOD",$JOB,DUZ(2),ACHSTY,ACHSACFY)=0
SET X=^TMP("ACHSOD",$JOB,DUZ(2),ACHSTY,ACHSACFY)
+14 SET $PIECE(X,U)=$PIECE(X,U)+1
+15 SET $PIECE(X,U,2)=$PIECE(X,U,2)+O
+16 SET ^TMP("ACHSOD",$JOB,DUZ(2),ACHSTY,ACHSACFY)=X
End DoDot:1
+17 ;
+18 ;SET THE FISCAL INTERMEDIARY
+19 SET ACHSFI=$SELECT(ACHSDEST="I":"IHS",1:"FISCAL AGENT")
+20 IF '$DATA(^TMP("ACHSOD",$JOB,DUZ(2),ACHSFI,ACHSACFY))
SET ^TMP("ACHSOD",$JOB,DUZ(2),ACHSFI,ACHSACFY)=0
+21 SET ^TMP("ACHSOD",$JOB,DUZ(2),ACHSFI,ACHSACFY)=^TMP("ACHSOD",$JOB,DUZ(2),ACHSFI,ACHSACFY)+1
+22 GOTO A4
+23 ;
A7 ;
+1 SET F=0
SET B=9999998-ACHSBDT
REGCHECK ;
+1 SET F=$ORDER(^TMP("ACHSOD",$JOB,DUZ(2),F))
SET R=""
SET W=0
+2 IF F<1
GOTO END
+3 SET N=$ORDER(^ACHS(9,DUZ(2),"FY",F,"AR",B))
IF N]""
SET W=$ORDER(^(N,0))
IF W
IF $DATA(^ACHS(9,DUZ(2),"FY",F,"W",W,1))
SET R=$GET(^ACHS(9,DUZ(2),"FY",F,"W",W,1))
+4 IF 'ACHSDCR
IF F'=ACHSCFY
DO CLSOPEN
+5 GOTO REGCHECK
+6 ;
END ;
+1 KILL ACHSDCR,ACHSTRDT,ACHSACY,ACHSDEST,ACHSDOCR,ACHSFI,ACHSZYR
+2 GOTO ^ACHSODP
+3 ;
CLSOPEN ;
+1 ;12/27/00 pmf remove naked refs
+2 SET $PIECE(^ACHS(9,DUZ(2),"FY",F,"W",W,0),U,2)=ACHSEDT
+3 SET R=$GET(^ACHS(9,DUZ(2),"FY",F,"W",W,1))
+4 SET ^ACHS(9,DUZ(2),"FY",F,"AR",9999999-ACHSEDT,W)=""
+5 ;
NEWREG ;
+1 SET W=W+1
+2 IF $DATA(^ACHS(9,DUZ(2),"FY",F,"W",W))
GOTO NEWREG
+3 SET ^ACHS(9,DUZ(2),"FY",F,"W",W,0)=W
+4 SET ^ACHS(9,DUZ(2),"FY",F,"W",W,1)=R
SET X="^9002069.02^"
+5 IF $DATA(^ACHS(9,DUZ(2),"FY",F,"W",0))
SET X=$GET(^ACHS(9,DUZ(2),"FY",F,"W",0))
+6 SET $PIECE(X,U,3)=W
SET $PIECE(X,U,4)=$PIECE(X,U,4)+1
SET ^ACHS(9,DUZ(2),"FY",F,"W",0)=X
+7 QUIT
+8 ;
