ACHSUUP ; IHS/ITSC/PMF - UPDATE OBLIGATION BALANCE/DCR ACCOUNTS/QUEUE DOCUMENTS ; [ 02/23/2005 11:39 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**7,8,9,12**;JUNE 11, 2001
;;ITSC/SET/JVK ACHS*3.1*7 ADDED SET OF ESIG TMP GLOBAL
;;ITSC/SET/JVK ACHS*3.1*8 ADDED SET OF ESIG TMP GLOBAL
;;ITSC/SET/JVK ACHS*3.1*9 FIX UNDEF OF ACHSTTYP
;;ITSC/SET/JVK ACHS*3.1*12 FIX ACHSTTYP AFTER PAYMT NO KILLED
;
D CKB,SBA:'$D(ACHSCNC)
Q
;
SBAENT ;EP - Update Current Advice of Allowance and Total Obligated FYTD.
SBA ;
I '$$LOCK^ACHS("^ACHS(9,DUZ(2))","+") W !,"LOCK OF '^ACHS(9,",DUZ(2),") FAILED AT SBA^ACHSUUP." Q
;
;'CURRENT ADVICE OF ALLOWANCE' ;'TOTAL OBLIGATED FYTD'
S X=$G(^ACHS(9,DUZ(2),"FY",ACHSACFY,0))
S X1=$P(X,U,2)
S X2=$P(X,U,3)
I $D(ACHSISAO) G SBB
;
;'NEG. UNOBLIGATED BAL. PRIOR FY'?
I $$PARM^ACHS(2,2)="Y",ACHSACFY<ACHSCFY G SBB
I ACHSESDO<1 G SBB ; Cancel;IF 'IHS PAYMENT AMOUNT' NOT THERE CANCEL
;
;IF 'TOTAL OBLIGATED FYTD'+'IHS PAYMENT AMT' IS NOT GREATER THAN
;'CURRENT ADVICE OF ALLOWANCE' THEN CONTINUE WE HAVE MONIES
I (X2+ACHSESDO'>X1) G SBB
W *7,!,"Funds are not available for this transaction",!,"Transanction Cancelled"
;
;
W:ACHSACFY<ACHSCFY !!,"'",$P(^DD(9002080,14.02,0),U),"' parameter = '",$$PARM^ACHS(2,2),"'.",!!
S ACHSCNC=""
G SBAEND
;
SBB ;
I ACHS("CHK")>0 G SBAEND
;
;X IS STILL ^ACHS(9,DUZ(2),"FY",ACHSACFY,0)
;ADD 'TOTAL OBLIGATED FYTD' TO 'IHS PAYMENT AMOUNT'
;PUT BACK INTO TOTAL OBLIGATED FYTD
S $P(X,U,3)=$P(X,U,3)+ACHSESDO
;
;
S Y=$G(^ACHS(9,DUZ(2),"FY",ACHSACFY,"W",ACHSACWK,1)) ;DCR REGISTER BALANCES
S $P(Y,U,ACHSDCR)=$P(Y,U,ACHSDCR)+ACHSESDO ;ADD 'IHS PAYMENT AMOUNT TO REGISTER
S ^ACHS(9,DUZ(2),"FY",ACHSACFY,0)=X ;
S ^ACHS(9,DUZ(2),"FY",ACHSACFY,"W",ACHSACWK,1)=Y
;
;FIELD 8 'TOTAL AMT OBLIGATED'='TOTAL OBLIGATED AMT'+'IHS PAYMENT AMT'
I '$D(ACHSUFLG),$$DIE^ACHS("8///"_($$DOC^ACHS(0,9)+ACHSESDO))
SBAEND ;
I '$$LOCK^ACHS("^ACHS(9,DUZ(2))","-") W !,"UNLOCK OF '^ACHS(9,",DUZ(2),") FAILED AT SBAEND^ACHSUUP."
Q
;
SBQ ;EP - Place document in print list.
;
;QUIT IF HIGH VOLUME PROVIDER
Q:$D(^ACHSF(DUZ(2),18,"B",ACHSPROV))
S ^ACHSF("PQ",DUZ(2),ACHSTYP,ACHSDIEN,ACHSTIEN)="" ;PLACE IN PRINT QUE
;ITSC/SET/JVK ACHS*3.1*7 PLACE IN E-SIG QUE
;ITSC/SET/JVK ACHS*3.1*8 1.23.04 -ADD D LOOP PUT IN EQ ONLY INITIAL & SUPPLEMENT
I $P($G(^ACHSESIG(DUZ(2),0)),U,3)'="",DT>($P($G(^ACHSESIG(DUZ(2),0)),U,3)-1) D
.;ITSC/SET/JVK ACHS*3.1*9 3.1.04 - FIX UNDEF OF ACHSTTYP-NO SUPPLEMENTS IN EQ
.I $P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,3)=2 Q
.I $P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,24)'="" Q
.S ACHSTTYP=""
.I ACHSTIEN=1 S ACHSTTYP="I"
.;ITSC/SET/JVK ACHS*3.1*12 12/21/04 CHECK PATTERN MATCH TO BE ALPHA
.I ACHSTTYP'?1A.A S ACHSTTYP=$P(ACHSTRAN,U,2)
.I ACHSTTYP'?1A.A,ACHSTRAN="" S ACHSTTYP=$P(T,U,2)
.I ACHSTTYP="I" S ^ACHSF("EQ",DUZ(2),ACHSTYP,ACHSDIEN,ACHSTIEN)=""
.I ACHSTTYP="S",'$D(^ACHSF("EQ",DUZ(2),ACHSTYP,ACHSDIEN)) S ^ACHSF("EQ",DUZ(2),ACHSTYP,ACHSDIEN,ACHSTIEN)=""
.;I '$D(^ACHSF("EQ",DUZ(2),ACHSTYP,ACHSDIEN)) S ^JVKTMP=ACHSDIEN_U_ACHSTTYP_U_ACHSTRAN_U_ACHSTIEN
.Q
;ITSC/SET/JVK ACHS*3.1*12 12/21/04 KILL THE TRANSACTION TYPE
K ACHSTTYP
Q
;
AVAIL(A,Y,C) ;EP - Check if money "A" available for transaction in year "Y", "C" is current FY. 1=Yes, 0=No.
I $D(ACHSISAO) Q 1 ; Auto processing of EOBRs.
I $$PARM^ACHS(2,2)="Y",Y<C Q 1 ; Previous FY, parm sez OK.
I A<1 Q 1 ; Cancellation
N M,N
S X=$G(^ACHS(9,DUZ(2),"FY",Y,0)) ;GET FISCAL YEAR 0 NODE
S M=$P(X,U,2) ;'CURRENT ADVICE OF ALLOWANCE'
S N=$P(X,U,3) ;'TOTAL OBLIGATED FYTD'
I (N+A'>M) Q 1
Q 0
;
CKB ;EP - CK for "OUT-OF-BALANCE" condition.
;
; The sum of fields DCR-(1 thru 7) BALANCE of the current
; register must equal the TOTAL OBLIGATED FYTD field in
; the Fiscal Year in use.
;
K ACHSCNC
S ACHS("BALC")=0
;
F I=1:1:7 D ;ADD UP DCR BALANCES
.S ACHS("BALC")=ACHS("BALC")+$P(^ACHS(9,DUZ(2),"FY",ACHSACFY,"W",ACHSACWK,1),U,I)
;IF TOTAL DCR BALANCES EQUAL TOTAL OBLIGATED FYTD OKAY
I ACHS("BALC")=$P(^ACHS(9,DUZ(2),"FY",ACHSACFY,0),U,3) K ACHS("BALC") Q
;
S ACHSCNC=1 ;CANCEL FLAG
Q:$D(ACHSISAO) ;IS AREA OFFICE?
D VIDEO^ACHS ;SET REVERSE VIDEO VARIABLES
S ACHS=$$REPEAT^XLFSTR("*",79)
W *7,!!!!,ACHS,!!,ACHS,!!!?22,$G(IORVON),"THE REGISTERS ARE OUT OF BALANCE",$G(IORVOFF),!!?26,$G(IORVON),"CONTACT YOUR SITE MANAGER",$G(IORVOFF),!!!,ACHS,!!,ACHS,!
D RTRN^ACHS ;PRESS RETURN TO CONTINUE
I $D(^XUSEC("ACHSZMGR",DUZ)),$$DIR^XBDIR("Y","Want me to fix it for you","N","","","^D HELP^ACHSUUP",1) D FIX^ACHSBRF(ACHSACFY,ACHSACWK),RTRN^ACHS G CKB
Q
;
HELP ;EP - From DIR.
F %=2:1 W !?5,$P($T(HELP+%),";",3) Q:$P($T(HELP+%+1),";",3)=""
;;If you answer YES, the account balances and YTD oblligated will be
;;calculated from the existing documents, and the CHS DATA CONTROL
;;FILE will be updated accordingly.
Q
;
ACHSUUP ; IHS/ITSC/PMF - UPDATE OBLIGATION BALANCE/DCR ACCOUNTS/QUEUE DOCUMENTS ; [ 02/23/2005 11:39 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**7,8,9,12**;JUNE 11, 2001
+2 ;;ITSC/SET/JVK ACHS*3.1*7 ADDED SET OF ESIG TMP GLOBAL
+3 ;;ITSC/SET/JVK ACHS*3.1*8 ADDED SET OF ESIG TMP GLOBAL
+4 ;;ITSC/SET/JVK ACHS*3.1*9 FIX UNDEF OF ACHSTTYP
+5 ;;ITSC/SET/JVK ACHS*3.1*12 FIX ACHSTTYP AFTER PAYMT NO KILLED
+6 ;
+7 DO CKB
IF '$DATA(ACHSCNC)
DO SBA
+8 QUIT
+9 ;
SBAENT ;EP - Update Current Advice of Allowance and Total Obligated FYTD.
SBA ;
+1 IF '$$LOCK^ACHS("^ACHS(9,DUZ(2))","+")
WRITE !,"LOCK OF '^ACHS(9,",DUZ(2),") FAILED AT SBA^ACHSUUP."
QUIT
+2 ;
+3 ;'CURRENT ADVICE OF ALLOWANCE' ;'TOTAL OBLIGATED FYTD'
+4 SET X=$GET(^ACHS(9,DUZ(2),"FY",ACHSACFY,0))
+5 SET X1=$PIECE(X,U,2)
+6 SET X2=$PIECE(X,U,3)
+7 IF $DATA(ACHSISAO)
GOTO SBB
+8 ;
+9 ;'NEG. UNOBLIGATED BAL. PRIOR FY'?
+10 IF $$PARM^ACHS(2,2)="Y"
IF ACHSACFY<ACHSCFY
GOTO SBB
+11 ; Cancel;IF 'IHS PAYMENT AMOUNT' NOT THERE CANCEL
IF ACHSESDO<1
GOTO SBB
+12 ;
+13 ;IF 'TOTAL OBLIGATED FYTD'+'IHS PAYMENT AMT' IS NOT GREATER THAN
+14 ;'CURRENT ADVICE OF ALLOWANCE' THEN CONTINUE WE HAVE MONIES
+15 IF (X2+ACHSESDO'>X1)
GOTO SBB
+16 WRITE *7,!,"Funds are not available for this transaction",!,"Transanction Cancelled"
+17 ;
+18 ;
+19 IF ACHSACFY<ACHSCFY
WRITE !!,"'",$PIECE(^DD(9002080,14.02,0),U),"' parameter = '",$$PARM^ACHS(2,2),"'.",!!
+20 SET ACHSCNC=""
+21 GOTO SBAEND
+22 ;
SBB ;
+1 IF ACHS("CHK")>0
GOTO SBAEND
+2 ;
+3 ;X IS STILL ^ACHS(9,DUZ(2),"FY",ACHSACFY,0)
+4 ;ADD 'TOTAL OBLIGATED FYTD' TO 'IHS PAYMENT AMOUNT'
+5 ;PUT BACK INTO TOTAL OBLIGATED FYTD
+6 SET $PIECE(X,U,3)=$PIECE(X,U,3)+ACHSESDO
+7 ;
+8 ;
+9 ;DCR REGISTER BALANCES
SET Y=$GET(^ACHS(9,DUZ(2),"FY",ACHSACFY,"W",ACHSACWK,1))
+10 ;ADD 'IHS PAYMENT AMOUNT TO REGISTER
SET $PIECE(Y,U,ACHSDCR)=$PIECE(Y,U,ACHSDCR)+ACHSESDO
+11 ;
SET ^ACHS(9,DUZ(2),"FY",ACHSACFY,0)=X
+12 SET ^ACHS(9,DUZ(2),"FY",ACHSACFY,"W",ACHSACWK,1)=Y
+13 ;
+14 ;FIELD 8 'TOTAL AMT OBLIGATED'='TOTAL OBLIGATED AMT'+'IHS PAYMENT AMT'
+15 IF '$DATA(ACHSUFLG)
IF $$DIE^ACHS("8///"_($$DOC^ACHS(0,9)+ACHSESDO))
SBAEND ;
+1 IF '$$LOCK^ACHS("^ACHS(9,DUZ(2))","-")
WRITE !,"UNLOCK OF '^ACHS(9,",DUZ(2),") FAILED AT SBAEND^ACHSUUP."
+2 QUIT
+3 ;
SBQ ;EP - Place document in print list.
+1 ;
+2 ;QUIT IF HIGH VOLUME PROVIDER
+3 IF $DATA(^ACHSF(DUZ(2),18,"B",ACHSPROV))
QUIT
+4 ;PLACE IN PRINT QUE
SET ^ACHSF("PQ",DUZ(2),ACHSTYP,ACHSDIEN,ACHSTIEN)=""
+5 ;ITSC/SET/JVK ACHS*3.1*7 PLACE IN E-SIG QUE
+6 ;ITSC/SET/JVK ACHS*3.1*8 1.23.04 -ADD D LOOP PUT IN EQ ONLY INITIAL & SUPPLEMENT
+7 IF $PIECE($GET(^ACHSESIG(DUZ(2),0)),U,3)'=""
IF DT>($PIECE($GET(^ACHSESIG(DUZ(2),0)),U,3)-1)
Begin DoDot:1
+8 ;ITSC/SET/JVK ACHS*3.1*9 3.1.04 - FIX UNDEF OF ACHSTTYP-NO SUPPLEMENTS IN EQ
+9 IF $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,3)=2
QUIT
+10 IF $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,24)'=""
QUIT
+11 SET ACHSTTYP=""
+12 IF ACHSTIEN=1
SET ACHSTTYP="I"
+13 ;ITSC/SET/JVK ACHS*3.1*12 12/21/04 CHECK PATTERN MATCH TO BE ALPHA
+14 IF ACHSTTYP'?1A.A
SET ACHSTTYP=$PIECE(ACHSTRAN,U,2)
+15 IF ACHSTTYP'?1A.A
IF ACHSTRAN=""
SET ACHSTTYP=$PIECE(T,U,2)
+16 IF ACHSTTYP="I"
SET ^ACHSF("EQ",DUZ(2),ACHSTYP,ACHSDIEN,ACHSTIEN)=""
+17 IF ACHSTTYP="S"
IF '$DATA(^ACHSF("EQ",DUZ(2),ACHSTYP,ACHSDIEN))
SET ^ACHSF("EQ",DUZ(2),ACHSTYP,ACHSDIEN,ACHSTIEN)=""
+18 ;I '$D(^ACHSF("EQ",DUZ(2),ACHSTYP,ACHSDIEN)) S ^JVKTMP=ACHSDIEN_U_ACHSTTYP_U_ACHSTRAN_U_ACHSTIEN
+19 QUIT
End DoDot:1
+20 ;ITSC/SET/JVK ACHS*3.1*12 12/21/04 KILL THE TRANSACTION TYPE
+21 KILL ACHSTTYP
+22 QUIT
+23 ;
AVAIL(A,Y,C) ;EP - Check if money "A" available for transaction in year "Y", "C" is current FY. 1=Yes, 0=No.
+1 ; Auto processing of EOBRs.
IF $DATA(ACHSISAO)
QUIT 1
+2 ; Previous FY, parm sez OK.
IF $$PARM^ACHS(2,2)="Y"
IF Y<C
QUIT 1
+3 ; Cancellation
IF A<1
QUIT 1
+4 NEW M,N
+5 ;GET FISCAL YEAR 0 NODE
SET X=$GET(^ACHS(9,DUZ(2),"FY",Y,0))
+6 ;'CURRENT ADVICE OF ALLOWANCE'
SET M=$PIECE(X,U,2)
+7 ;'TOTAL OBLIGATED FYTD'
SET N=$PIECE(X,U,3)
+8 IF (N+A'>M)
QUIT 1
+9 QUIT 0
+10 ;
CKB ;EP - CK for "OUT-OF-BALANCE" condition.
+1 ;
+2 ; The sum of fields DCR-(1 thru 7) BALANCE of the current
+3 ; register must equal the TOTAL OBLIGATED FYTD field in
+4 ; the Fiscal Year in use.
+5 ;
+6 KILL ACHSCNC
+7 SET ACHS("BALC")=0
+8 ;
+9 ;ADD UP DCR BALANCES
FOR I=1:1:7
Begin DoDot:1
+10 SET ACHS("BALC")=ACHS("BALC")+$PIECE(^ACHS(9,DUZ(2),"FY",ACHSACFY,"W",ACHSACWK,1),U,I)
End DoDot:1
+11 ;IF TOTAL DCR BALANCES EQUAL TOTAL OBLIGATED FYTD OKAY
+12 IF ACHS("BALC")=$PIECE(^ACHS(9,DUZ(2),"FY",ACHSACFY,0),U,3)
KILL ACHS("BALC")
QUIT
+13 ;
+14 ;CANCEL FLAG
SET ACHSCNC=1
+15 ;IS AREA OFFICE?
IF $DATA(ACHSISAO)
QUIT
+16 ;SET REVERSE VIDEO VARIABLES
DO VIDEO^ACHS
+17 SET ACHS=$$REPEAT^XLFSTR("*",79)
+18 WRITE *7,!!!!,ACHS,!!,ACHS,!!!?22,$GET(IORVON),"THE REGISTERS ARE OUT OF BALANCE",$GET(IORVOFF),!!?26,$GET(IORVON),"CONTACT YOUR SITE MANAGER",$GET(IORVOFF),!!!,ACHS,!!,ACHS,!
+19 ;PRESS RETURN TO CONTINUE
DO RTRN^ACHS
+20 IF $DATA(^XUSEC("ACHSZMGR",DUZ))
IF $$DIR^XBDIR("Y","Want me to fix it for you","N","","","^D HELP^ACHSUUP",1)
DO FIX^ACHSBRF(ACHSACFY,ACHSACWK)
DO RTRN^ACHS
GOTO CKB
+21 QUIT
+22 ;
HELP ;EP - From DIR.
+1 FOR %=2:1
WRITE !?5,$PIECE($TEXT(HELP+%),";",3)
IF $PIECE($TEXT(HELP+%+1),";",3)=""
QUIT
+2 ;;If you answer YES, the account balances and YTD oblligated will be
+3 ;;calculated from the existing documents, and the CHS DATA CONTROL
+4 ;;FILE will be updated accordingly.
+5 QUIT
+6 ;
