ACRFEA.m

ACRFEA ;IHS/OIRM/DSD/THL,AEF - EDIT FINANCIAL DATA;  [ 11/01/2001   9:44 AM ]

 ;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001

 ;;ROUTINE TO EDIT FINANCIAL DATA

EN ;EP;

 I $D(ACRNEWOB),(ACRENTRY["OBLAMT") D EN1,EXIT Q

 F  D EN1 Q:$D(ACRQUIT)!$D(ACROUT)

EXIT D EXITFEA^ACRFEXIT

 W @IOF

 Q

EN1 D SET

 I $D(ACRRR)#2 D  Q

 .D ^ACRFRR

 .K ACRRR

 .S ACRQUIT=""

 D FDTP1:'$D(ACRQUIT)

 D ^ACRFEA4:'$D(ACRQUIT)&'$D(ACRPRT)&'$D(ACRCSI)

 Q:$D(ACROUT)!$D(ACRQUIT)!$D(ACROUT)

 D TRANS^ACRFEA2:ACRENTRY'["APP"&(ACRENTRY'["OBLAMT")

 Q

FDTP1 ;CONTROLLER FOR DIC("S") FOR ALL ACCOUNT AND OBLIGATIONS LOOKUPS

 I ACRENTRY["APPAMT",$D(ACRFDNO) D  Q

 .S DA=ACRFDNO

 .D ^ACRFEA4

 .S ACRQUIT=""

 I ACRENTRY["FDIS",$D(ACRFDNO) D FDTP11 Q

 I '$D(ACRNEWOB) D FDTP12

 I ACRENTRY["ALLAMT" D  Q

 .S DIC("S")="I $P(^ACRALW(+Y,0),U,2)=ACRFDNO,$D(^ACRALW(""SEC"","_DUZ_",+Y))"

 .D DIC

 I ACRENTRY["ALC" D  Q

 .S DIC("S")="I $P(^ACRALC(+Y,0),U,3)=ACRFDNO,$D(^ACRALC(""SEC"","_DUZ_",+Y))"

 .D DIC

 I ACRENTRY["LOCB" D  Q

 .S DIC("S")="I $P(^ACRLOCB(+Y,0),U,4)=ACRFDNO,$D(^ACRLOCB(""SEC"","_DUZ_",+Y))"

 .D DIC

 Q:ACRENTRY'["OBLA"

ACRREV I $D(ACRREV),$D(ACRCOMP) D  Q

 .S DIC("S")="S ACR=^ACRDOC(+Y,0),ACRAPV=$G(^ACROBL(+Y,""APV"")) I $P(ACR,U,6)=ACRFDNO,""ACD""[$E(ACRAPV)!(""ACD""[$P(ACRAPV,U,3)) W @(""$E(""_DIC_""Y,0),0)"")"

 .D DIC

 I $D(ACRREV) D  Q

 .S DIC("S")="I $P(ACR,U,6)=ACRFDNO W @(""$E(""_DIC_""Y,0),0)"")"

 .D DIC

ACRCSI I $D(ACRCSI) D  Q

 .S DIC("S")="S ACR=^ACRDOC(+Y,0) I $P(ACR,U,6)=ACRFDNO W @(""$E(""_DIC_""Y,0),0)"")"

 .D DIC

REACT I $D(ACRREACT),'$D(ACRJVOD) D  Q

 .S DIC("S")="S ACR=^ACRDOC(+Y,0),ACRAPV=$G(^ACROBL(+Y,""APV"")) I $P(ACR,U,6)=ACRFDNO,'$$OBL^ACRFEA(+Y),$P(ACRAPV,U)]"""",""ACD""[$P(ACRAPV,U)!(""D""[$P(ACRAPV,U,3)) W @(""$E(""_DIC_""Y,0),0)"")"

 .K ACRQUIT

 .D DIC

JVOD I $D(ACRJVOD) D  Q

 .S DIC("S")="S ACR=^ACRDOC(+Y,0),ACRAPV=$G(^ACROBL(+Y,""APV"")) I $P(ACR,U,6)=ACRFDNO,$E(ACRAPV)=""A"",$P(ACRAPV,U,3)=""A"" W @(""$E(""_DIC_""Y,0),0)"")"

 .D DIC

ACRCTV I $D(ACRCTV) D  Q

 .S DIC("S")="S ACR=^ACRDOC(+Y,0),ACRAPV=$G(^ACROBL(+Y,""APV"")) I $P(ACR,U,6)=ACRFDNO,$P(ACRAPV,U)]"""",""CD""'[$E(ACRAPV),$P(ACRAPV,U,7)=19,$P(ACRAPV,U,8)="""",$P(ACR,U,13)=$O(^AUTTDOCR(""B"",600,0)) W @(""$E(""_DIC_""Y,0),0)"")"

 .D DIC

ACRCONV I $D(ACRCONV),'$D(ACRCTV) D  Q

 .S DIC("S")="S ACR=^ACRDOC(+Y,0),ACRAPV=$G(^ACROBL(+Y,""APV"")) I $P(ACR,U,6)=ACRFDNO,$P(^ACROBL(Y,""CONV""),U)=""Y"" W @(""$E(""_DIC_""Y,0),0)"")"

 .D DIC

ACRTV I '$D(ACRREACT) D  Q

 .S DIC("S")="S ACR=^ACRDOC(+Y,0),ACRAPV=$G(^ACROBL(+Y,""APV"")) I $P(ACR,U,6)=ACRFDNO,$P(ACRAPV,U)="""",$P(ACRAPV,U,3)="""" W @(""$E(""_DIC_""Y,0),0)"")"

 .D DIC

 Q

DIC I $D(ACRCSIS) D PAUSE^ACRFWARN S ACRQUIT="" Q

 W !

 D EDIC

 Q:$D(ACRQUIT)!$D(ACROUT)

 Q

FDTP11 S ACRLBDA=ACRFDNO

 S ACRALCDA=$P(^ACRLOCB(ACRLBDA,0),U,4)

 D ^ACRFDIS

 S ACRQUIT=""

 Q

FDTP12 S ACRFADD=""

 S:$D(ACRLBDA) ACRDISDA=ACRLBDA

 S ACRDISP=""

 D FDTP^ACRFDTP

 K ACRFADD

 Q

SET ;EP;

 S (ACRDIC,ACRDIE)=$P(ACRENTRY,";;",3)

 S ACRGREF=$P(ACRDIC,"(")

 S ACRDR=$P(ACRENTRY,";;",5)

 S ACRDIC("A")=$P(ACRENTRY,";;",6)

 S ACRD=$P(ACRENTRY,";;",7)

 S ACRDIC(0)="AELNZ"

 S ACRRTN="^"_$P(ACRENTRY,";;",4)

 S (ACRY,ACRTYPS)=$P(ACRENTRY,";;",2)

 S ACRENTR2=$P(ACRENTRY," ")

 Q

EDIC S DIC("DR")=""

 I ACRENTRY["OBLAMT" D  I 1

 .D ^ACRFEA1

 .K ACRCONT

 E  D DIC1^ACRFEA2

DICC Q:$D(ACRQUIT)!$D(ACROUT)!'$D(ACRZY)

 Q:($P(ACRZY,U,3)'=1)!$D(ACRPRT)

 I ACRENTRY'["DOC",ACRENTRY'["APP",ACRENTRY'["OBLA" D  Q

 .S DA=ACRZDA

 .S DIE=ACRDIE

 .S DR=$S((ACRENTRY["ALLAMT"):".02",ACRENTRY["LOCB":".04",1:".03")

 .S DR=DR_"////"_ACRFDNO_";2////0.00;3////0.00;800////N"

 .D DIE^ACRFDIC

 I ACRENTRY["OBLA" D

 .S ACRFINSS=""

 .S DA=ACRDOCDA

 .S DIE="^ACRDOC("

 .S DR=".05////"_ACRDOCDA_";.06////"_ACRFDNO

 .D DIE^ACRFDIC

 I ACRENTRY'["OBLA" D

 .S ACRFINSS=""

 .S DA=ACRZDA

 .S DIE=ACRDIE

 .S DR=ACRDR

 .D DIE^ACRFDIC

 Q

ENTRY ;EP;CONTROLS EDITING DEPENDING ON VALUE OF 'ACRENTRY' WHEN ROUTINE CALLED

 S ACRENTRY=$T(@ACRENTRY^ACRFCTL1)

 S ACRZY=""

 G EN

 Q

DISP ;EP;TO DISPLAY FINANCIAL ACCOUNT DATA

 W @IOF

 W ?20,"Current ",@ACRON,ACRFDNY,@ACROF," data:"

 W !

 N DXS,DIP,DC,DN,D0

 S D0=ACRZDA

 D @ACRRTN

 Q

OBL(X) ;EP;DETERMINE IF OBLIGATION HAS BEEN MADE AGAINST THE DOCUMENT      

 Q:'X

 N Y,ACRQUIT

 S Y=0

 S ACRQUIT=""

 F  S Y=$O(^ACRDHR("E",X,Y)) Q:'Y  D

 .I $P($G(^ACRDHR(+Y,1)),U,3,4)="050^1" S ACRQUIT=1

 .I $P($G(^ACRDHR(+Y,1)),U,3,4)="050^2" S ACRQUIT=0

 Q ACRQUIT

ACRFEA    ;IHS/OIRM/DSD/THL,AEF - EDIT FINANCIAL DATA;  [ 11/01/2001   9:44 AM ]

 +1       ;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001

 +2       ;;ROUTINE TO EDIT FINANCIAL DATA

EN        ;EP;

 +1        IF $DATA(ACRNEWOB)

               IF (ACRENTRY["OBLAMT")

                   DO EN1

                   DO EXIT

                   QUIT 

 +2        FOR 

               DO EN1

               IF $DATA(ACRQUIT)!$DATA(ACROUT)

                   QUIT 

EXIT       DO EXITFEA^ACRFEXIT

 +1        WRITE @IOF

 +2        QUIT 

EN1        DO SET

 +1        IF $DATA(ACRRR)#2

               Begin DoDot:1

 +2                DO ^ACRFRR

 +3                KILL ACRRR

 +4                SET ACRQUIT=""

               End DoDot:1

               QUIT 

 +5        IF '$DATA(ACRQUIT)

               DO FDTP1

 +6        IF '$DATA(ACRQUIT)&'$DATA(ACRPRT)&'$DATA(ACRCSI)

               DO ^ACRFEA4

 +7        IF $DATA(ACROUT)!$DATA(ACRQUIT)!$DATA(ACROUT)

               QUIT 

 +8        IF ACRENTRY'["APP"&(ACRENTRY'["OBLAMT")

               DO TRANS^ACRFEA2

 +9        QUIT 

FDTP1     ;CONTROLLER FOR DIC("S") FOR ALL ACCOUNT AND OBLIGATIONS LOOKUPS

 +1        IF ACRENTRY["APPAMT"

               IF $DATA(ACRFDNO)

                   Begin DoDot:1

 +2                    SET DA=ACRFDNO

 +3                    DO ^ACRFEA4

 +4                    SET ACRQUIT=""

                   End DoDot:1

                   QUIT 

 +5        IF ACRENTRY["FDIS"

               IF $DATA(ACRFDNO)

                   DO FDTP11

                   QUIT 

 +6        IF '$DATA(ACRNEWOB)

               DO FDTP12

 +7        IF ACRENTRY["ALLAMT"

               Begin DoDot:1

 +8                SET DIC("S")="I $P(^ACRALW(+Y,0),U,2)=ACRFDNO,$D(^ACRALW(""SEC"","_DUZ_",+Y))"

 +9                DO DIC

               End DoDot:1

               QUIT 

 +10       IF ACRENTRY["ALC"

               Begin DoDot:1

 +11               SET DIC("S")="I $P(^ACRALC(+Y,0),U,3)=ACRFDNO,$D(^ACRALC(""SEC"","_DUZ_",+Y))"

 +12               DO DIC

               End DoDot:1

               QUIT 

 +13       IF ACRENTRY["LOCB"

               Begin DoDot:1

 +14               SET DIC("S")="I $P(^ACRLOCB(+Y,0),U,4)=ACRFDNO,$D(^ACRLOCB(""SEC"","_DUZ_",+Y))"

 +15               DO DIC

               End DoDot:1

               QUIT 

 +16       IF ACRENTRY'["OBLA"

               QUIT 

ACRREV     IF $DATA(ACRREV)

               IF $DATA(ACRCOMP)

                   Begin DoDot:1

 +1                    SET DIC("S")="S ACR=^ACRDOC(+Y,0),ACRAPV=$G(^ACROBL(+Y,""APV"")) I $P(ACR,U,6)=ACRFDNO,""ACD""[$E(ACRAPV)!(""ACD""[$P(ACRAPV,U,3)) W @(""$E(""_DIC_""Y,0),0)"")"

 +2                    DO DIC

                   End DoDot:1

                   QUIT 

 +3        IF $DATA(ACRREV)

               Begin DoDot:1

 +4                SET DIC("S")="I $P(ACR,U,6)=ACRFDNO W @(""$E(""_DIC_""Y,0),0)"")"

 +5                DO DIC

               End DoDot:1

               QUIT 

ACRCSI     IF $DATA(ACRCSI)

               Begin DoDot:1

 +1                SET DIC("S")="S ACR=^ACRDOC(+Y,0) I $P(ACR,U,6)=ACRFDNO W @(""$E(""_DIC_""Y,0),0)"")"

 +2                DO DIC

               End DoDot:1

               QUIT 

REACT      IF $DATA(ACRREACT)

               IF '$DATA(ACRJVOD)

                   Begin DoDot:1

 +1                    SET DIC("S")="S ACR=^ACRDOC(+Y,0),ACRAPV=$G(^ACROBL(+Y,""APV"")) I $P(ACR,U,6)=ACRFDNO,'$$OBL^ACRFEA(+Y),$P(ACRAPV,U)]"""",""ACD""[$P(ACRAPV,U)!(""D""[$P(ACRAPV,U,3)) W @(""$E(""_DIC_""Y,0),0)"")"

 +2                    KILL ACRQUIT

 +3                    DO DIC

                   End DoDot:1

                   QUIT 

JVOD       IF $DATA(ACRJVOD)

               Begin DoDot:1

 +1                SET DIC("S")="S ACR=^ACRDOC(+Y,0),ACRAPV=$G(^ACROBL(+Y,""APV"")) I $P(ACR,U,6)=ACRFDNO,$E(ACRAPV)=""A"",$P(ACRAPV,U,3)=""A"" W @(""$E(""_DIC_""Y,0),0)"")"

 +2                DO DIC

               End DoDot:1

               QUIT 

ACRCTV     IF $DATA(ACRCTV)

               Begin DoDot:1

 +1                SET DIC("S")="S ACR=^ACRDOC(+Y,0),ACRAPV=$G(^ACROBL(+Y,""APV"")) I $P(ACR,U,6)=ACRFDNO,$P(ACRAPV,U)]"""",""CD""'[$E(ACRAPV),$P(ACRAPV,U,7)=19,$P(ACRAPV,U,8)="""",$P(ACR,U,13)=$O(^AUTTDOCR(""B"",600,0)) W @(""$E(""_DIC_""Y,0),0)"")"

 +2                DO DIC

               End DoDot:1

               QUIT 

ACRCONV    IF $DATA(ACRCONV)

               IF '$DATA(ACRCTV)

                   Begin DoDot:1

 +1                    SET DIC("S")="S ACR=^ACRDOC(+Y,0),ACRAPV=$G(^ACROBL(+Y,""APV"")) I $P(ACR,U,6)=ACRFDNO,$P(^ACROBL(Y,""CONV""),U)=""Y"" W @(""$E(""_DIC_""Y,0),0)"")"

 +2                    DO DIC

                   End DoDot:1

                   QUIT 

ACRTV      IF '$DATA(ACRREACT)

               Begin DoDot:1

 +1                SET DIC("S")="S ACR=^ACRDOC(+Y,0),ACRAPV=$G(^ACROBL(+Y,""APV"")) I $P(ACR,U,6)=ACRFDNO,$P(ACRAPV,U)="""",$P(ACRAPV,U,3)="""" W @(""$E(""_DIC_""Y,0),0)"")"

 +2                DO DIC

               End DoDot:1

               QUIT 

 +3        QUIT 

DIC        IF $DATA(ACRCSIS)

               DO PAUSE^ACRFWARN

               SET ACRQUIT=""

               QUIT 

 +1        WRITE !

 +2        DO EDIC

 +3        IF $DATA(ACRQUIT)!$DATA(ACROUT)

               QUIT 

 +4        QUIT 

FDTP11     SET ACRLBDA=ACRFDNO

 +1        SET ACRALCDA=$PIECE(^ACRLOCB(ACRLBDA,0),U,4)

 +2        DO ^ACRFDIS

 +3        SET ACRQUIT=""

 +4        QUIT 

FDTP12     SET ACRFADD=""

 +1        IF $DATA(ACRLBDA)

               SET ACRDISDA=ACRLBDA

 +2        SET ACRDISP=""

 +3        DO FDTP^ACRFDTP

 +4        KILL ACRFADD

 +5        QUIT 

SET       ;EP;

 +1        SET (ACRDIC,ACRDIE)=$PIECE(ACRENTRY,";;",3)

 +2        SET ACRGREF=$PIECE(ACRDIC,"(")

 +3        SET ACRDR=$PIECE(ACRENTRY,";;",5)

 +4        SET ACRDIC("A")=$PIECE(ACRENTRY,";;",6)

 +5        SET ACRD=$PIECE(ACRENTRY,";;",7)

 +6        SET ACRDIC(0)="AELNZ"

 +7        SET ACRRTN="^"_$PIECE(ACRENTRY,";;",4)

 +8        SET (ACRY,ACRTYPS)=$PIECE(ACRENTRY,";;",2)

 +9        SET ACRENTR2=$PIECE(ACRENTRY," ")

 +10       QUIT 

EDIC       SET DIC("DR")=""

 +1        IF ACRENTRY["OBLAMT"

               Begin DoDot:1

 +2                DO ^ACRFEA1

 +3                KILL ACRCONT

               End DoDot:1

               IF 1

 +4       IF '$TEST

               DO DIC1^ACRFEA2

DICC       IF $DATA(ACRQUIT)!$DATA(ACROUT)!'$DATA(ACRZY)

               QUIT 

 +1        IF ($PIECE(ACRZY,U,3)'=1)!$DATA(ACRPRT)

               QUIT 

 +2        IF ACRENTRY'["DOC"

               IF ACRENTRY'["APP"

                   IF ACRENTRY'["OBLA"

                       Begin DoDot:1

 +3                        SET DA=ACRZDA

 +4                        SET DIE=ACRDIE

 +5                        SET DR=$SELECT((ACRENTRY["ALLAMT"):".02",ACRENTRY["LOCB":".04",1:".03")

 +6                        SET DR=DR_"////"_ACRFDNO_";2////0.00;3////0.00;800////N"

 +7                        DO DIE^ACRFDIC

                       End DoDot:1

                       QUIT 

 +8        IF ACRENTRY["OBLA"

               Begin DoDot:1

 +9                SET ACRFINSS=""

 +10               SET DA=ACRDOCDA

 +11               SET DIE="^ACRDOC("

 +12               SET DR=".05////"_ACRDOCDA_";.06////"_ACRFDNO

 +13               DO DIE^ACRFDIC

               End DoDot:1

 +14       IF ACRENTRY'["OBLA"

               Begin DoDot:1

 +15               SET ACRFINSS=""

 +16               SET DA=ACRZDA

 +17               SET DIE=ACRDIE

 +18               SET DR=ACRDR

 +19               DO DIE^ACRFDIC

               End DoDot:1

 +20       QUIT 

ENTRY     ;EP;CONTROLS EDITING DEPENDING ON VALUE OF 'ACRENTRY' WHEN ROUTINE CALLED

 +1        SET ACRENTRY=$TEXT(@ACRENTRY^ACRFCTL1)

 +2        SET ACRZY=""

 +3        GOTO EN

 +4        QUIT 

DISP      ;EP;TO DISPLAY FINANCIAL ACCOUNT DATA

 +1        WRITE @IOF

 +2        WRITE ?20,"Current ",@ACRON,ACRFDNY,@ACROF," data:"

 +3        WRITE !

 +4        NEW DXS,DIP,DC,DN,D0

 +5        SET D0=ACRZDA

 +6        DO @ACRRTN

 +7        QUIT 

OBL(X)    ;EP;DETERMINE IF OBLIGATION HAS BEEN MADE AGAINST THE DOCUMENT      

 +1        IF 'X

               QUIT 

 +2        NEW Y,ACRQUIT

 +3        SET Y=0

 +4        SET ACRQUIT=""

 +5        FOR 

               SET Y=$ORDER(^ACRDHR("E",X,Y))

               IF 'Y

                   QUIT 

               Begin DoDot:1

 +6                IF $PIECE($GET(^ACRDHR(+Y,1)),U,3,4)="050^1"

                       SET ACRQUIT=1

 +7                IF $PIECE($GET(^ACRDHR(+Y,1)),U,3,4)="050^2"

                       SET ACRQUIT=0

               End DoDot:1

 +8        QUIT ACRQUIT