ACHSAS ; IHS/ITSC/PMF - SUPPLEMENTAL DOCUMENTS ; [ 10/16/2001 8:16 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
;
A1 ; Setup environment.
;
D ^ACHSUSC ;DISPLAY DOC. CANCEL/SUPPLEMENT INFO
I $D(DUOUT) D ENDC Q
Q:'$D(ACHSDIEN)
;
W !
I '$$LOCK^ACHS("^ACHSF(DUZ(2),""D"",ACHSDIEN)","+") D ENDC Q
;
;
S ACHSX=+$$DOC^ACHS(0,14) ;GET FISCAL YEAR DIGIT
D FYCVT^ACHSFU ;COMPUTE FISCAL YEAR
S ACHSACFY=ACHSY,ACHSACWK=+ACHSFYWK(DUZ(2),ACHSACFY)
D CKB^ACHSUUP ;CHECK BALANCES
I $D(ACHSCNC) D END Q ;QUIT IF BALANCES DONT CHECK
;
B2 ; Enter ammount of suplement.
W !!,"Amount Of Supplement: "
D READ^ACHSFU
I $D(DTOUT) D ENDC Q
G A1:$D(DUOUT)
;
I Y?1"?".E W !," Enter The Amount To Be Added (e.g. 150.00)." G B2
I Y="" W *7," NO AMOUNT ADDED",!!
S:Y?1"$".E Y=$E(Y,2,99)
F I=1:1 S F=$F(Y,",") Q:'F S Y=$E(Y,1,F-2)_$E(Y,F,99)
I '(Y?1N.N1"."2N!(Y?1N.N))!($L(Y)>10) W *7," ??" G A1
;
S ACHSADAM=Y D OBLM^ACHSFU ;CHECK IF OBLIGATION LIMIT FOR
; ;THIS TYPE DOC. IS EXCEEDED
G:$D(DUOUT) B2
;
C ; Confirm data.
S ACHSESDO=Y
W " ("
S X=ACHSESDO
D FMT^ACHS
W ")"
S Y=$$DIR^XBDIR("Y","Is everything correct","NO","","","",2)
I $D(DIRUT) D ENDC Q
G B2:$D(DUOUT)!('Y)
;
D1 ; Create internal transaction.
D SBA ;CHECK FOR FUNDS AVAILABLE
I $D(ACHSCNC) D ENDC Q ;IS CANCEL FLAG SET?
;
S T=DT_"^S^"_$G(DFN)_U_ACHSESDO
;
D SB1 ;CREATE TRANSACTION RECORD
;
END ;
I '$D(ACHSCNC) W !!," *** Document Updated ***" D ACT^ACHSACT(ACHSDIEN,$$NOW^XLFDT,"<SUPPLEMENTAL>")
I $$DOC^ACHS(2,7) S ACHSREF=$$DOC^ACHS(2,7) D AUTH^ACHSBMC K ACHSREF
ENDC ;
I $G(ACHSDIEN),$$LOCK^ACHS("^ACHSF(DUZ(2),""D"",ACHSDIEN)","-")
I $$DIR^XBDIR("E","Press RETURN...","","","","",1)
QUIT ; Kill vars, quit.
K X,X1,X2
Q
;
;SET THE TRANSACTION RECORD BYPASSING FILEMAN ???????
SB1 ;
S X=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,0)),ACHSDCR=-1,LS=+$P(X,U,15),ACHSDCR=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,0)),U,19)
I ACHSDCR<1 W !,"ERROR :Unknown DCR account number." Q
S:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0)) ^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0)=$$ZEROTH^ACHS(9002080,100,100)
S Y=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0))
S11 ;
S M=$P(Y,U,3)+1,$P(Y,U,3)=M,$P(Y,U,4)=M
G S11:$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",M))
S ^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0)=Y,^ACHSF(DUZ(2),"D",ACHSDIEN,"T",M,0)=T,^ACHSF(DUZ(2),"TB",DT,"S",ACHSDIEN,M)="",ACHSTIEN=M
S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",M,0),U,6)=LS+1,$P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,15)=LS+1
S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",M,0),U,11)=DUZ
S ACHS("CHK")=0
D SBAENT^ACHSUUP
D SKILL:$D(ACHSCNC)
D SBQ^ACHSUUP:$$PARM^ACHS(2,7)="Y"
Q
;
SKILL ;
S X=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0)),U,3)
S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0),U,3)=X-1
S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0),U,4)=X-1
K ^ACHSF(DUZ(2),"D",ACHSDIEN,"T",M),^ACHSF(DUZ(2),"TB",DT,"S",ACHSDIEN,M)
S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,15)=LS
Q
;
SBA ; Check for funds available.
I '$$LOCK^ACHS("^ACHS(9,DUZ(2))","+") W !,"LOCK UNSUCCESSFUL, SBA^ACHSAS." S ACHSCNC="" Q
S X=$G(^ACHS(9,DUZ(2),"FY",ACHSACFY,0)) ;
S X1=$P(X,U,2) ;CURRENT ADVICE OF ALLOWANCE
S X2=$P(X,U,3) ;TOTAL OBLIGATED FYTD
I '$$LOCK^ACHS("^ACHS(9,DUZ(2))","-")
I $$PARM^ACHS(2,2)="Y",ACHSACFY<ACHSCFY Q
I X2+ACHSESDO>X1 W *7,!,"Funds are not available for this transaction",!,"Transaction Cancelled" S ACHSCNC=""
Q
;
ACHSAS ; IHS/ITSC/PMF - SUPPLEMENTAL DOCUMENTS ; [ 10/16/2001 8:16 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
+2 ;
A1 ; Setup environment.
+1 ;
+2 ;DISPLAY DOC. CANCEL/SUPPLEMENT INFO
DO ^ACHSUSC
+3 IF $DATA(DUOUT)
DO ENDC
QUIT
+4 IF '$DATA(ACHSDIEN)
QUIT
+5 ;
+6 WRITE !
+7 IF '$$LOCK^ACHS("^ACHSF(DUZ(2),""D"",ACHSDIEN)","+")
DO ENDC
QUIT
+8 ;
+9 ;
+10 ;GET FISCAL YEAR DIGIT
SET ACHSX=+$$DOC^ACHS(0,14)
+11 ;COMPUTE FISCAL YEAR
DO FYCVT^ACHSFU
+12 SET ACHSACFY=ACHSY
SET ACHSACWK=+ACHSFYWK(DUZ(2),ACHSACFY)
+13 ;CHECK BALANCES
DO CKB^ACHSUUP
+14 ;QUIT IF BALANCES DONT CHECK
IF $DATA(ACHSCNC)
DO END
QUIT
+15 ;
B2 ; Enter ammount of suplement.
+1 WRITE !!,"Amount Of Supplement: "
+2 DO READ^ACHSFU
+3 IF $DATA(DTOUT)
DO ENDC
QUIT
+4 IF $DATA(DUOUT)
GOTO A1
+5 ;
+6 IF Y?1"?".E
WRITE !," Enter The Amount To Be Added (e.g. 150.00)."
GOTO B2
+7 IF Y=""
WRITE *7," NO AMOUNT ADDED",!!
+8 IF Y?1"$".E
SET Y=$EXTRACT(Y,2,99)
+9 FOR I=1:1
SET F=$FIND(Y,",")
IF 'F
QUIT
SET Y=$EXTRACT(Y,1,F-2)_$EXTRACT(Y,F,99)
+10 IF '(Y?1N.N1"."2N!(Y?1N.N))!($LENGTH(Y)>10)
WRITE *7," ??"
GOTO A1
+11 ;
+12 ;CHECK IF OBLIGATION LIMIT FOR
SET ACHSADAM=Y
DO OBLM^ACHSFU
+13 ; ;THIS TYPE DOC. IS EXCEEDED
+14 IF $DATA(DUOUT)
GOTO B2
+15 ;
C ; Confirm data.
+1 SET ACHSESDO=Y
+2 WRITE " ("
+3 SET X=ACHSESDO
+4 DO FMT^ACHS
+5 WRITE ")"
+6 SET Y=$$DIR^XBDIR("Y","Is everything correct","NO","","","",2)
+7 IF $DATA(DIRUT)
DO ENDC
QUIT
+8 IF $DATA(DUOUT)!('Y)
GOTO B2
+9 ;
D1 ; Create internal transaction.
+1 ;CHECK FOR FUNDS AVAILABLE
DO SBA
+2 ;IS CANCEL FLAG SET?
IF $DATA(ACHSCNC)
DO ENDC
QUIT
+3 ;
+4 SET T=DT_"^S^"_$GET(DFN)_U_ACHSESDO
+5 ;
+6 ;CREATE TRANSACTION RECORD
DO SB1
+7 ;
END ;
+1 IF '$DATA(ACHSCNC)
WRITE !!," *** Document Updated ***"
DO ACT^ACHSACT(ACHSDIEN,$$NOW^XLFDT,"<SUPPLEMENTAL>")
+2 IF $$DOC^ACHS(2,7)
SET ACHSREF=$$DOC^ACHS(2,7)
DO AUTH^ACHSBMC
KILL ACHSREF
ENDC ;
+1 IF $GET(ACHSDIEN)
IF $$LOCK^ACHS("^ACHSF(DUZ(2),""D"",ACHSDIEN)","-")
+2 IF $$DIR^XBDIR("E","Press RETURN...","","","","",1)
QUIT ; Kill vars, quit.
+1 KILL X,X1,X2
+2 QUIT
+3 ;
+4 ;SET THE TRANSACTION RECORD BYPASSING FILEMAN ???????
SB1 ;
+1 SET X=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,0))
SET ACHSDCR=-1
SET LS=+$PIECE(X,U,15)
SET ACHSDCR=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,0)),U,19)
+2 IF ACHSDCR<1
WRITE !,"ERROR :Unknown DCR account number."
QUIT
+3 IF '$DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0))
SET ^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0)=$$ZEROTH^ACHS(9002080,100,100)
+4 SET Y=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0))
S11 ;
+1 SET M=$PIECE(Y,U,3)+1
SET $PIECE(Y,U,3)=M
SET $PIECE(Y,U,4)=M
+2 IF $DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",M))
GOTO S11
+3 SET ^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0)=Y
SET ^ACHSF(DUZ(2),"D",ACHSDIEN,"T",M,0)=T
SET ^ACHSF(DUZ(2),"TB",DT,"S",ACHSDIEN,M)=""
SET ACHSTIEN=M
+4 SET $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",M,0),U,6)=LS+1
SET $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,15)=LS+1
+5 SET $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",M,0),U,11)=DUZ
+6 SET ACHS("CHK")=0
+7 DO SBAENT^ACHSUUP
+8 IF $DATA(ACHSCNC)
DO SKILL
+9 IF $$PARM^ACHS(2,7)="Y"
DO SBQ^ACHSUUP
+10 QUIT
+11 ;
SKILL ;
+1 SET X=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0)),U,3)
+2 SET $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0),U,3)=X-1
+3 SET $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0),U,4)=X-1
+4 KILL ^ACHSF(DUZ(2),"D",ACHSDIEN,"T",M),^ACHSF(DUZ(2),"TB",DT,"S",ACHSDIEN,M)
+5 SET $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,15)=LS
+6 QUIT
+7 ;
SBA ; Check for funds available.
+1 IF '$$LOCK^ACHS("^ACHS(9,DUZ(2))","+")
WRITE !,"LOCK UNSUCCESSFUL, SBA^ACHSAS."
SET ACHSCNC=""
QUIT
+2 ;
SET X=$GET(^ACHS(9,DUZ(2),"FY",ACHSACFY,0))
+3 ;CURRENT ADVICE OF ALLOWANCE
SET X1=$PIECE(X,U,2)
+4 ;TOTAL OBLIGATED FYTD
SET X2=$PIECE(X,U,3)
+5 IF '$$LOCK^ACHS("^ACHS(9,DUZ(2))","-")
+6 IF $$PARM^ACHS(2,2)="Y"
IF ACHSACFY<ACHSCFY
QUIT
+7 IF X2+ACHSESDO>X1
WRITE *7,!,"Funds are not available for this transaction",!,"Transaction Cancelled"
SET ACHSCNC=""
+8 QUIT
+9 ;
