ACHSALUP.m

ACHSALUP ; IHS/ITSC/PMF - UPDATE FACILITY FISCAL YEAR ALLOWANCE ;    [ 10/16/2001   8:16 AM ]

 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001

 ;

L1 ;

 S ACHSFYAL=$$FYSEL^ACHS

 G QUIT:$D(DUOUT)!$D(DTOUT)!('ACHSFYAL)

 I '$D(^ACHS(9,DUZ(2),"FY",ACHSFYAL,0)) W !!,"Allowance for this FISCAL YEAR Does NOT Exist -- Please Try Another Year" G L1

 S X=+$P($G(^ACHS(9,DUZ(2),"FY",ACHSFYAL,0)),U,2)

 W !!,"YTD allowance for ",ACHSFYAL," is:",$J("$ "_$FN(X,",",2),20)

 S X=$P($G(^ACHS(9,DUZ(2),"FY",ACHSFYAL,0)),U,2)-$P($G(^ACHS(9,DUZ(2),"FY",ACHSFYAL,0)),U,3)

 W !,"   Unobligated Balance is:",$J("$ "_$FN(X,",",2),20)

L2 ;

 S Y=$$DIR^XBDIR("9002069.01,1","Enter new YTD Advice of Allowance","","Please enter the NEW ALLOWANCE (e.g. 1000.00)","","",2)

 G NOUPD:$D(DUOUT)!$D(DTOUT)!(Y'>0)

 S:$E(Y)="$" Y=$E(Y,2,999)

 W !!,"For Fiscal Year ",ACHSFYAL," the new Allowance is "

 F ACHS=0:0 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 L2

 I Y>0 S ACHSCAOA=Y W "  " S X=Y,X2=2 D FMT^ACHS

 G UPDATE:$$DIR^XBDIR("Y","Are you sure this NEW ALLOWANCE is CORRECT","NO","","","",2)

NOUPD ;

 W !!,*7,?10,"******  ALLOWANCE  NOT  UPDATED  ******"

 G END

 ;

UPDATE ;

 I '$$LOCK^ACHS("^ACHS(9,DUZ(2),""FY"",ACHSFYAL,0)","+") G NOUPD

 S $P(^ACHS(9,DUZ(2),"FY",ACHSFYAL,0),U,2)=ACHSCAOA

 S $P(^ACHS(9,DUZ(2),"FY",ACHSFYAL,0),U,4)=DT

 S $P(^ACHS(9,DUZ(2),"FY",ACHSFYAL,0),U,5)=DUZ

 I '$$LOCK^ACHS("^ACHS(9,DUZ(2),""FY"",ACHSFYAL,0)","-")

 W !!?20,"******  ALLOWANCE UPDATED  ******"

END ;

 D:$G(ACHSFYAL) INITIALS(ACHSFYAL)

QUIT ;

 K ACHSFYAL,ACHSCAOA

 D RTRN^ACHS

 Q

 ;

INITIALS(ACHSFYAL) ;EP - Update Initial Register Values

 S Y=0

 F X=1:1:7 S Y=Y+$P($G(^ACHS(9,DUZ(2),"FY",ACHSFYAL,1)),U,X)

 I '(+Y=+$P($G(^ACHS(9,DUZ(2),"FY",ACHSFYAL,0)),U,2)) W *7,!!,"Your Initial Balance values don't = your Advice of Allowance (That's OK)."

 K X,Y

 Q:'$$DIR^XBDIR("Y","Do you want to update the Initial Balance values","N","","","^D HELP^ACHS(""H"",""ACHSALUP"")",1)

 N DA,DIE,DR

 S DIE="^ACHS(9,"_DUZ(2)_",""FY"",",DA(1)=DUZ(2),DA=ACHSFYAL,DR="10:16"

 I '$$LOCK^ACHS("^ACHS(9,DUZ(2),""FY"",ACHSFYAL)","+") Q

 D ^DIE

 I '$$LOCK^ACHS("^ACHS(9,DUZ(2),""FY"",ACHSFYAL)","-")

 Q

 ;

H ;EP - From DIR via HELP^ACHS().

 ;;If you answer yes, you will be able to edit the values in your

 ;;7 Initial Registers, which will appear on your Account Balances

 ;;display / print-out.

 ;;###

 ;

DIE(DR,Z) ;EP - Edit Document fields.

 I $G(Z) F %=1:1:Z W !

 S DA=ACHSDIEN,DA(1)=DUZ(2),DIE="^ACHSF("_DUZ(2)_",""D"","

ACHSALUP  ; IHS/ITSC/PMF - UPDATE FACILITY FISCAL YEAR ALLOWANCE ;    [ 10/16/2001   8:16 AM ]

 +1       ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001

 +2       ;

L1        ;

 +1        SET ACHSFYAL=$$FYSEL^ACHS

 +2        IF $DATA(DUOUT)!$DATA(DTOUT)!('ACHSFYAL)

               GOTO QUIT

 +3        IF '$DATA(^ACHS(9,DUZ(2),"FY",ACHSFYAL,0))

               WRITE !!,"Allowance for this FISCAL YEAR Does NOT Exist -- Please Try Another Year"

               GOTO L1

 +4        SET X=+$PIECE($GET(^ACHS(9,DUZ(2),"FY",ACHSFYAL,0)),U,2)

 +5        WRITE !!,"YTD allowance for ",ACHSFYAL," is:",$JUSTIFY("$ "_$FNUMBER(X,",",2),20)

 +6        SET X=$PIECE($GET(^ACHS(9,DUZ(2),"FY",ACHSFYAL,0)),U,2)-$PIECE($GET(^ACHS(9,DUZ(2),"FY",ACHSFYAL,0)),U,3)

 +7        WRITE !,"   Unobligated Balance is:",$JUSTIFY("$ "_$FNUMBER(X,",",2),20)

L2        ;

 +1        SET Y=$$DIR^XBDIR("9002069.01,1","Enter new YTD Advice of Allowance","","Please enter the NEW ALLOWANCE (e.g. 1000.00)","","",2)

 +2        IF $DATA(DUOUT)!$DATA(DTOUT)!(Y'>0)

               GOTO NOUPD

 +3        IF $EXTRACT(Y)="$"

               SET Y=$EXTRACT(Y,2,999)

 +4        WRITE !!,"For Fiscal Year ",ACHSFYAL," the new Allowance is "

 +5        FOR ACHS=0:0

               SET F=$FIND(Y,",")

               IF 'F

                   QUIT 

               SET Y=$EXTRACT(Y,1,F-2)_$EXTRACT(Y,F,99)

 +6        IF '(Y?1N.N1"."2N!(Y?1N.N))!($LENGTH(Y)>10)

               WRITE *7,"  ??"

               GOTO L2

 +7        IF Y>0

               SET ACHSCAOA=Y

               WRITE "  "

               SET X=Y

               SET X2=2

               DO FMT^ACHS

 +8        IF $$DIR^XBDIR("Y","Are you sure this NEW ALLOWANCE is CORRECT","NO","","","",2)

               GOTO UPDATE

NOUPD     ;

 +1        WRITE !!,*7,?10,"******  ALLOWANCE  NOT  UPDATED  ******"

 +2        GOTO END

 +3       ;

UPDATE    ;

 +1        IF '$$LOCK^ACHS("^ACHS(9,DUZ(2),""FY"",ACHSFYAL,0)","+")

               GOTO NOUPD

 +2        SET $PIECE(^ACHS(9,DUZ(2),"FY",ACHSFYAL,0),U,2)=ACHSCAOA

 +3        SET $PIECE(^ACHS(9,DUZ(2),"FY",ACHSFYAL,0),U,4)=DT

 +4        SET $PIECE(^ACHS(9,DUZ(2),"FY",ACHSFYAL,0),U,5)=DUZ

 +5        IF '$$LOCK^ACHS("^ACHS(9,DUZ(2),""FY"",ACHSFYAL,0)","-")

 +6        WRITE !!?20,"******  ALLOWANCE UPDATED  ******"

END       ;

 +1        IF $GET(ACHSFYAL)

               DO INITIALS(ACHSFYAL)

QUIT      ;

 +1        KILL ACHSFYAL,ACHSCAOA

 +2        DO RTRN^ACHS

 +3        QUIT 

 +4       ;

INITIALS(ACHSFYAL) ;EP - Update Initial Register Values

 +1        SET Y=0

 +2        FOR X=1:1:7

               SET Y=Y+$PIECE($GET(^ACHS(9,DUZ(2),"FY",ACHSFYAL,1)),U,X)

 +3        IF '(+Y=+$PIECE($GET(^ACHS(9,DUZ(2),"FY",ACHSFYAL,0)),U,2))

               WRITE *7,!!,"Your Initial Balance values don't = your Advice of Allowance (That's OK)."

 +4        KILL X,Y

 +5        IF '$$DIR^XBDIR("Y","Do you want to update the Initial Balance values","N","","","^D HELP^ACHS(""H"",""ACHSALUP"")",1)

               QUIT 

 +6        NEW DA,DIE,DR

 +7        SET DIE="^ACHS(9,"_DUZ(2)_",""FY"","

           SET DA(1)=DUZ(2)

           SET DA=ACHSFYAL

           SET DR="10:16"

 +8        IF '$$LOCK^ACHS("^ACHS(9,DUZ(2),""FY"",ACHSFYAL)","+")

               QUIT 

 +9        DO ^DIE

 +10       IF '$$LOCK^ACHS("^ACHS(9,DUZ(2),""FY"",ACHSFYAL)","-")

 +11       QUIT 

 +12      ;

H         ;EP - From DIR via HELP^ACHS().

 +1       ;;If you answer yes, you will be able to edit the values in your

 +2       ;;7 Initial Registers, which will appear on your Account Balances

 +3       ;;display / print-out.

 +4       ;;###

 +5       ;

DIE(DR,Z) ;EP - Edit Document fields.

 +1        IF $GET(Z)

               FOR %=1:1:Z

                   WRITE !

 +2        SET DA=ACHSDIEN

           SET DA(1)=DUZ(2)

           SET DIE="^ACHSF("_DUZ(2)_",""D"","