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