ACHSUF ; IHS/ITSC/PMF - SET CHS FACILITY VARS, CHECK DATA INTEGRITY ; [ 10/16/2001 8:16 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
;
I $D(ACHSCHSS) S ACHSCHSS="V"
E S ACHSCHSS=""
I '$D(^ACHS(9,DUZ(2),"CHK")) S ^ACHS(9,DUZ(2),"CHK")=""
D FC
I $D(ACHSERR),ACHSERR=1 G K
D C0SUB
I $D(ACHSERR),ACHSERR=1 G GLOBERR
G ERR:'$D(^ACHS(9,DUZ(2),0))
D FY
G S16:'$D(ACHSFYWK(DUZ(2),ACHSCFY))
S ACHSACWK=ACHSFYWK(DUZ(2),ACHSCFY)
I ACHSACWK=0,'$D(^ACHS(9,DUZ(2),"FY",ACHSACFY,0)) G S16
I $D(^ACHS(9,DUZ(2),"FY",ACHSACFY,"W",ACHSACWK,0)) S ACHS("ZL")=$P(^(0),U,2) G END:ACHS("ZL")="",S15:+ACHS("ZL")'<DT!(+ACHS("ZL")=DT)
I ACHSACWK,$D(^ACHS(9,DUZ(2),"FY",ACHSACFY,"W",ACHSACWK,0)) S ACHS("ZL")=$P(^(0),U,2) G END:ACHS("ZL")="",S15:ACHS("ZL")'<DT!(+ACHS("ZL")=DT)
;
G END:$D(^ACHS(9,DUZ(2),"FY",ACHSACFY,"W",ACHSACWK+1,0))
G S17:'$D(^ACHS(9,DUZ(2),"FY",ACHSACFY,"W",ACHSACWK,1))
;
INIT ;EP
S R=0
I '$$LOCK^ACHS("^ACHS(9,DUZ(2))","+") W !,"LOCK FAILED AT INIT+2^ACHSUF" S ACHSERR=10 Q
I1 ;
S R=$O(ACHSFYWK(DUZ(2),R))
G INITEND:+R=0
S X=+ACHSFYWK(DUZ(2),R),ACHSXX=$G(^ACHS(9,DUZ(2),"FY",R,"W",X,1))
S ^ACHS(9,DUZ(2),"FY",R,"W",X+1,0)=X+1
S ^ACHS(9,DUZ(2),"FY",R,"W",X+1,1)=ACHSXX
S $P(^ACHS(9,DUZ(2),"FY",R,"W",0),U,4)=$P(^ACHS(9,DUZ(2),"FY",R,"W",0),U,4)+1,$P(^(0),U,3)=X+1
G I1
;
INITEND ;
I '$$LOCK^ACHS("^ACHS(9,DUZ(2))","-")
END ;
S ACHSERR=0
K ACHSGCHK
D C0SUB
G GLOBERR:ACHSERR>0
S ^ACHS(9,DUZ(2),"CHK")=DT
K ;
K ACHS("FYX"),ACHS("ZL"),ACHSACWK,ACHSCHSS,ACHSXX
Q
;
ERR ;
W:'$D(ACHSISAO) *7,!!," The Parameters For This Facility Are Incomplete"
ERR1 ;
S ACHSERR=1
W:'$D(ACHSISAO) !!?15,"PLEASE CONTACT YOUR SITE MANAGER FOR ASSISTANCE",!
G K
;
INERR ;
W:'$D(ACHSISAO) *7,!!," THE PARAMETER FILE FOR THIS FACILITY HAS NOT BEEN INITIALIZED,",!
G ERR1
;
FNCDERR ;
W:'$D(ACHSISAO) *7,!!?10,"THE FINANCE PARAMETERS FOR THIS FACILITY ARE INCOMPLETE,",!
G ERR1
;
GLOBERR ;EP.
W:'$D(ACHSISAO) *7,!!," AN ERROR HAS BEEN DETECTED IN GLOBAL STRUCTURE OF 'CHS DATA CONTROL' FILE"
G ERR1
;
S15 ;
W:ACHSCHSS'="V"&('$D(ACHSISAO)) !!,"The Control Register Has Been CLOSED For This Date"
G S18
;
S16 ;
Q:$D(ACHS("SETNEW"))
Q:$D(ACHSISAO)
U IO(0)
W *7,*7,!!!,"THE CHS SYSTEM HAS NOT BEEN INITIALIZED FOR THE CURRENT FISCAL YEAR",!!
S Y=$$DIR^XBDIR("Y","SHALL I SET IT UP FOR YOU NOW","NO","","","^D HELP^ACHS(""H"",""ACHSUF"")")
I $D(DUOUT)!$D(DTOUT)!('Y) S ACHSERR=1 G K
S ACHS("YR")=ACHSACFY,ACHSAUTO=""
W !!,"SETTING UP NEW FISCAL YEAR. PLEASE WAIT........"
D AUTO^ACHSNEW
I $D(ACHSERR),ACHSERR=1 G ERR1
D C0SUB
U IO(0)
W *7,*7,!!,"A NEW FISCAL YEAR "_ACHSCFY_" HAS BEEN SET UP.",!,"PLEASE NOTIFY THE CONTRACT HEALTH MANAGER.",!
I $$DIR^XBDIR("E","Press RETURN...")
Q
;
S17 ;
U IO(0)
W:'$D(ACHSISAO) !!,"SYSTEM ERROR"
S18 ;
W:ACHSCHSS'="V"&('$D(ACHSISAO)) *7,!!
G END
;
C0SUB ;EP - Ensure the number of registers agree with 0th node.
; Set the ACHSFYWK array.
; ACHSRX is Fiscal Year. ACHSRXX is Register (DCR) number.
I ^ACHS(9,DUZ(2),"CHK")=DT D WK Q
S (ACHSRX,ACHSRXX)=0
C1 ;
S ACHSRX=$O(^ACHS(9,DUZ(2),"FY",ACHSRX))
G C1:ACHSRX=0,CEND:+ACHSRX=0
S (ACHSRXX,ACHSTCNT)=0
S ACHSSRXX=""
C2 ;
F ACHS=0:0 S ACHSRXX=$O(^ACHS(9,DUZ(2),"FY",ACHSRX,"W",ACHSRXX)) Q:+ACHSRXX=0 S ACHSFYWK(DUZ(2),ACHSRX)=ACHSRXX,ACHSTCNT=ACHSTCNT+1,ACHSSRXX=ACHSRXX,ACHS("FYX")=ACHSRX
C3 ;
I '$D(^ACHS(9,DUZ(2),"FY",ACHSRX,"W")) S ACHSERR=1 G CEND
I ACHSTCNT'=$P(^ACHS(9,DUZ(2),"FY",ACHSRX,"W",0),U,4) S ACHSERR=1
I ACHSSRXX'=$P(^ACHS(9,DUZ(2),"FY",ACHSRX,"W",0),U,3) S ACHSERR=1
G C1
;
CEND ;
K ACHSTCNT,ACHSRX,ACHSRXX,ACHSSRXX
Q
;
FY ;EP - Set FY and Current FY.
S ACHSACFY=$E(DT,1,3)
;
; IHS facilities FY start date is Oct 1.
I $P(^ACHSF(DUZ(2),0),U,8)'="Y" S $P(^ACHSF(DUZ(2),0),U,6)="1001",$P(^ACHSF(DUZ(2),0),U,7)=1
;
; 638 facilities not having FY start date will default to Oct 1.
I '$P(^ACHSF(DUZ(2),0),U,6) S $P(^(0),U,6)="1001",$P(^(0),U,7)=1
;
; Calculate when the next FY starts.
S ACHSFYDT=$E(DT,1,3)_$P($G(^ACHSF(DUZ(2),0)),U,6)
I $E(DT,4,7)>($E(ACHSFYDT,4,7)-1) S ACHSFYDT=ACHSFYDT+10000
;
; Check if today is after FY start date, adjust with parameter.
I $E(DT,4,7)>($P($G(^ACHSF(DUZ(2),0)),U,6)-1) S ACHSACFY=ACHSACFY+$P($G(^(0)),U,7)
; Some 638 facilities do not start FY until after the CY starts.
I $E(DT,4,7)<($P($G(^ACHSF(DUZ(2),0)),U,6)),'$P($G(^(0)),U,7) S ACHSACFY=ACHSACFY-1
S ACHSACFY=ACHSACFY+1700,ACHSCFY=ACHSACFY
Q
;
FC ;EP - Set Finance Code.
K ACHSERR
S ACHSFC=$P($G(^AUTTLOC(DUZ(2),0)),U,17)
I $L(ACHSFC)'=3 G FNCDERR
S ACHSFC=$P($G(^AUTTAREA($P($G(^AUTTLOC(DUZ(2),0)),U,4),0)),U,3)_$E(ACHSFC,2,3)
Q
;
WK ;SET ACHSFYWK ARRAY
S ACHSRX=0
WK1 ;
S ACHSRX=$O(^ACHS(9,DUZ(2),"FY",ACHSRX))
G WK1:ACHSRX=0
I +ACHSRX=0 K ACHSRX Q
S ACHSFYWK(DUZ(2),ACHSRX)=$P($G(^ACHS(9,DUZ(2),"FY",ACHSRX,"W",0)),U,3)
G WK1
Q
;
H ;EP - From DIR via HELP^ACHS().
;;@;!,"IF YOU ANSWER 'Y' OR 'YES' A NEW FISCAL YEAR ENTRY WILL BE CREATED."
;;@;!,"IF YOU ANSWER 'N' OR 'NO' YOU WILL EXIT BACK TO THE MENU."
;;@;!,"IF YOU HAVE QUESTIONS PLEASE CONTACT YOUR CONTRACT HEALTH MANAGER.",!
;;@;$S($$DIR^XBDIR("E","Press <RETURN> To Continue...."):"",1:"")
;;###
;
ACHSUF ; IHS/ITSC/PMF - SET CHS FACILITY VARS, CHECK DATA INTEGRITY ; [ 10/16/2001 8:16 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
+2 ;
+3 IF $DATA(ACHSCHSS)
SET ACHSCHSS="V"
+4 IF '$TEST
SET ACHSCHSS=""
+5 IF '$DATA(^ACHS(9,DUZ(2),"CHK"))
SET ^ACHS(9,DUZ(2),"CHK")=""
+6 DO FC
+7 IF $DATA(ACHSERR)
IF ACHSERR=1
GOTO K
+8 DO C0SUB
+9 IF $DATA(ACHSERR)
IF ACHSERR=1
GOTO GLOBERR
+10 IF '$DATA(^ACHS(9,DUZ(2),0))
GOTO ERR
+11 DO FY
+12 IF '$DATA(ACHSFYWK(DUZ(2),ACHSCFY))
GOTO S16
+13 SET ACHSACWK=ACHSFYWK(DUZ(2),ACHSCFY)
+14 IF ACHSACWK=0
IF '$DATA(^ACHS(9,DUZ(2),"FY",ACHSACFY,0))
GOTO S16
+15 IF $DATA(^ACHS(9,DUZ(2),"FY",ACHSACFY,"W",ACHSACWK,0))
SET ACHS("ZL")=$PIECE(^(0),U,2)
IF ACHS("ZL")=""
GOTO END
IF +ACHS("ZL")'<DT!(+ACHS("ZL")=DT)
GOTO S15
+16 IF ACHSACWK
IF $DATA(^ACHS(9,DUZ(2),"FY",ACHSACFY,"W",ACHSACWK,0))
SET ACHS("ZL")=$PIECE(^(0),U,2)
IF ACHS("ZL")=""
GOTO END
IF ACHS("ZL")'<DT!(+ACHS("ZL")=DT)
GOTO S15
+17 ;
+18 IF $DATA(^ACHS(9,DUZ(2),"FY",ACHSACFY,"W",ACHSACWK+1,0))
GOTO END
+19 IF '$DATA(^ACHS(9,DUZ(2),"FY",ACHSACFY,"W",ACHSACWK,1))
GOTO S17
+20 ;
INIT ;EP
+1 SET R=0
+2 IF '$$LOCK^ACHS("^ACHS(9,DUZ(2))","+")
WRITE !,"LOCK FAILED AT INIT+2^ACHSUF"
SET ACHSERR=10
QUIT
I1 ;
+1 SET R=$ORDER(ACHSFYWK(DUZ(2),R))
+2 IF +R=0
GOTO INITEND
+3 SET X=+ACHSFYWK(DUZ(2),R)
SET ACHSXX=$GET(^ACHS(9,DUZ(2),"FY",R,"W",X,1))
+4 SET ^ACHS(9,DUZ(2),"FY",R,"W",X+1,0)=X+1
+5 SET ^ACHS(9,DUZ(2),"FY",R,"W",X+1,1)=ACHSXX
+6 SET $PIECE(^ACHS(9,DUZ(2),"FY",R,"W",0),U,4)=$PIECE(^ACHS(9,DUZ(2),"FY",R,"W",0),U,4)+1
SET $PIECE(^(0),U,3)=X+1
+7 GOTO I1
+8 ;
INITEND ;
+1 IF '$$LOCK^ACHS("^ACHS(9,DUZ(2))","-")
END ;
+1 SET ACHSERR=0
+2 KILL ACHSGCHK
+3 DO C0SUB
+4 IF ACHSERR>0
GOTO GLOBERR
+5 SET ^ACHS(9,DUZ(2),"CHK")=DT
K ;
+1 KILL ACHS("FYX"),ACHS("ZL"),ACHSACWK,ACHSCHSS,ACHSXX
+2 QUIT
+3 ;
ERR ;
+1 IF '$DATA(ACHSISAO)
WRITE *7,!!," The Parameters For This Facility Are Incomplete"
ERR1 ;
+1 SET ACHSERR=1
+2 IF '$DATA(ACHSISAO)
WRITE !!?15,"PLEASE CONTACT YOUR SITE MANAGER FOR ASSISTANCE",!
+3 GOTO K
+4 ;
INERR ;
+1 IF '$DATA(ACHSISAO)
WRITE *7,!!," THE PARAMETER FILE FOR THIS FACILITY HAS NOT BEEN INITIALIZED,",!
+2 GOTO ERR1
+3 ;
FNCDERR ;
+1 IF '$DATA(ACHSISAO)
WRITE *7,!!?10,"THE FINANCE PARAMETERS FOR THIS FACILITY ARE INCOMPLETE,",!
+2 GOTO ERR1
+3 ;
GLOBERR ;EP.
+1 IF '$DATA(ACHSISAO)
WRITE *7,!!," AN ERROR HAS BEEN DETECTED IN GLOBAL STRUCTURE OF 'CHS DATA CONTROL' FILE"
+2 GOTO ERR1
+3 ;
S15 ;
+1 IF ACHSCHSS'="V"&('$DATA(ACHSISAO))
WRITE !!,"The Control Register Has Been CLOSED For This Date"
+2 GOTO S18
+3 ;
S16 ;
+1 IF $DATA(ACHS("SETNEW"))
QUIT
+2 IF $DATA(ACHSISAO)
QUIT
+3 USE IO(0)
+4 WRITE *7,*7,!!!,"THE CHS SYSTEM HAS NOT BEEN INITIALIZED FOR THE CURRENT FISCAL YEAR",!!
+5 SET Y=$$DIR^XBDIR("Y","SHALL I SET IT UP FOR YOU NOW","NO","","","^D HELP^ACHS(""H"",""ACHSUF"")")
+6 IF $DATA(DUOUT)!$DATA(DTOUT)!('Y)
SET ACHSERR=1
GOTO K
+7 SET ACHS("YR")=ACHSACFY
SET ACHSAUTO=""
+8 WRITE !!,"SETTING UP NEW FISCAL YEAR. PLEASE WAIT........"
+9 DO AUTO^ACHSNEW
+10 IF $DATA(ACHSERR)
IF ACHSERR=1
GOTO ERR1
+11 DO C0SUB
+12 USE IO(0)
+13 WRITE *7,*7,!!,"A NEW FISCAL YEAR "_ACHSCFY_" HAS BEEN SET UP.",!,"PLEASE NOTIFY THE CONTRACT HEALTH MANAGER.",!
+14 IF $$DIR^XBDIR("E","Press RETURN...")
+15 QUIT
+16 ;
S17 ;
+1 USE IO(0)
+2 IF '$DATA(ACHSISAO)
WRITE !!,"SYSTEM ERROR"
S18 ;
+1 IF ACHSCHSS'="V"&('$DATA(ACHSISAO))
WRITE *7,!!
+2 GOTO END
+3 ;
C0SUB ;EP - Ensure the number of registers agree with 0th node.
+1 ; Set the ACHSFYWK array.
+2 ; ACHSRX is Fiscal Year. ACHSRXX is Register (DCR) number.
+3 IF ^ACHS(9,DUZ(2),"CHK")=DT
DO WK
QUIT
+4 SET (ACHSRX,ACHSRXX)=0
C1 ;
+1 SET ACHSRX=$ORDER(^ACHS(9,DUZ(2),"FY",ACHSRX))
+2 IF ACHSRX=0
GOTO C1
IF +ACHSRX=0
GOTO CEND
+3 SET (ACHSRXX,ACHSTCNT)=0
+4 SET ACHSSRXX=""
C2 ;
+1 FOR ACHS=0:0
SET ACHSRXX=$ORDER(^ACHS(9,DUZ(2),"FY",ACHSRX,"W",ACHSRXX))
IF +ACHSRXX=0
QUIT
SET ACHSFYWK(DUZ(2),ACHSRX)=ACHSRXX
SET ACHSTCNT=ACHSTCNT+1
SET ACHSSRXX=ACHSRXX
SET ACHS("FYX")=ACHSRX
C3 ;
+1 IF '$DATA(^ACHS(9,DUZ(2),"FY",ACHSRX,"W"))
SET ACHSERR=1
GOTO CEND
+2 IF ACHSTCNT'=$PIECE(^ACHS(9,DUZ(2),"FY",ACHSRX,"W",0),U,4)
SET ACHSERR=1
+3 IF ACHSSRXX'=$PIECE(^ACHS(9,DUZ(2),"FY",ACHSRX,"W",0),U,3)
SET ACHSERR=1
+4 GOTO C1
+5 ;
CEND ;
+1 KILL ACHSTCNT,ACHSRX,ACHSRXX,ACHSSRXX
+2 QUIT
+3 ;
FY ;EP - Set FY and Current FY.
+1 SET ACHSACFY=$EXTRACT(DT,1,3)
+2 ;
+3 ; IHS facilities FY start date is Oct 1.
+4 IF $PIECE(^ACHSF(DUZ(2),0),U,8)'="Y"
SET $PIECE(^ACHSF(DUZ(2),0),U,6)="1001"
SET $PIECE(^ACHSF(DUZ(2),0),U,7)=1
+5 ;
+6 ; 638 facilities not having FY start date will default to Oct 1.
+7 IF '$PIECE(^ACHSF(DUZ(2),0),U,6)
SET $PIECE(^(0),U,6)="1001"
SET $PIECE(^(0),U,7)=1
+8 ;
+9 ; Calculate when the next FY starts.
+10 SET ACHSFYDT=$EXTRACT(DT,1,3)_$PIECE($GET(^ACHSF(DUZ(2),0)),U,6)
+11 IF $EXTRACT(DT,4,7)>($EXTRACT(ACHSFYDT,4,7)-1)
SET ACHSFYDT=ACHSFYDT+10000
+12 ;
+13 ; Check if today is after FY start date, adjust with parameter.
+14 IF $EXTRACT(DT,4,7)>($PIECE($GET(^ACHSF(DUZ(2),0)),U,6)-1)
SET ACHSACFY=ACHSACFY+$PIECE($GET(^(0)),U,7)
+15 ; Some 638 facilities do not start FY until after the CY starts.
+16 IF $EXTRACT(DT,4,7)<($PIECE($GET(^ACHSF(DUZ(2),0)),U,6))
IF '$PIECE($GET(^(0)),U,7)
SET ACHSACFY=ACHSACFY-1
+17 SET ACHSACFY=ACHSACFY+1700
SET ACHSCFY=ACHSACFY
+18 QUIT
+19 ;
FC ;EP - Set Finance Code.
+1 KILL ACHSERR
+2 SET ACHSFC=$PIECE($GET(^AUTTLOC(DUZ(2),0)),U,17)
+3 IF $LENGTH(ACHSFC)'=3
GOTO FNCDERR
+4 SET ACHSFC=$PIECE($GET(^AUTTAREA($PIECE($GET(^AUTTLOC(DUZ(2),0)),U,4),0)),U,3)_$EXTRACT(ACHSFC,2,3)
+5 QUIT
+6 ;
WK ;SET ACHSFYWK ARRAY
+1 SET ACHSRX=0
WK1 ;
+1 SET ACHSRX=$ORDER(^ACHS(9,DUZ(2),"FY",ACHSRX))
+2 IF ACHSRX=0
GOTO WK1
+3 IF +ACHSRX=0
KILL ACHSRX
QUIT
+4 SET ACHSFYWK(DUZ(2),ACHSRX)=$PIECE($GET(^ACHS(9,DUZ(2),"FY",ACHSRX,"W",0)),U,3)
+5 GOTO WK1
+6 QUIT
+7 ;
H ;EP - From DIR via HELP^ACHS().
+1 ;;@;!,"IF YOU ANSWER 'Y' OR 'YES' A NEW FISCAL YEAR ENTRY WILL BE CREATED."
+2 ;;@;!,"IF YOU ANSWER 'N' OR 'NO' YOU WILL EXIT BACK TO THE MENU."
+3 ;;@;!,"IF YOU HAVE QUESTIONS PLEASE CONTACT YOUR CONTRACT HEALTH MANAGER.",!
+4 ;;@;$S($$DIR^XBDIR("E","Press <RETURN> To Continue...."):"",1:"")
+5 ;;###
+6 ;
