Routine: PRCEOB

PRCEOB ;WISC/CLH/CTB-1358 OBLIGATION ; 15 Apr 93  1:02 PM

V ;;5.1;IFCAP;;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 K PRC,PRCF,Y

 S PRCF("X")="AB" D ^PRCFSITE Q:'%

 D LOOKUP G:Y<0 OUT K DIC,OB,DA,DIR,TRNODE,PCP,IOINHI,IOINLOW,IOINORM,X,PO,PODA,PRCHP,PATNUM,TR3,TR4,PO0,%,MSG S (OB,DA)=+Y

SC D NODE^PRCS58OB(DA,.TRNODE)

 S PRCFA("TRDA")=OB D SCREEN^PRCEOB1 W ! S DIR(0)="Y",DIR("A")="Is the above information correct",DIR("B")="YES",DIR("?")="'NO' will allow you to edit the information, '^' to Exit" D ^DIR G:$D(DIRUT) OUT

 K DIR G:$D(DIRUT) OUT I 'Y D OB^PRCS58OB(OB) G SC

 S PCP=$P(TRNODE(0),"-",4),PQT=$P(TRNODE(0),"-",3) D CPBAL^PRCFAC01 K PQT,PRCF("NOBAL") S DIR(0)="Y",DIR("A")="OK to continue",DIR("B")="YES" D ^DIR G:'Y!($D(DTOUT)) OUT

 K DA,X S PRCHP("T")=21,PRCHP("S")=4,PRCHP("A")="1358 Obligation Number",PRCFA(1358)="" D EN^PRCHPAT K PRCFA(1358),PRCHP I '$D(DA) S X="Unable to establish Obligation Number, processing has been terminated.*" D MSG^PRCFQ G OUT

 D OB1^PRCS58OB(OB,DA)

 D PAT^PRCH58OB(DA,.PODA,.PO,.PATNUM)

 D COB^PRCH58OB(PODA,.TRNODE,.PO,OB,X)

 N PRCFA,PRCFDEL,AMT,CS,DA,DIK,TIME

TT S PRCFA("REF")=$P($P(PO(0),"^"),"-",2),PRCFA("SYS")="CLM" S PRCFA("TT")="921.60" D TT^PRCFAC G:'% KILL

 I "921.00921.10921.24921.60921.71"'[PRCFA("TT") W " Invalid Transaction Type.Status Code selected. ",!?20,"921.00, 921.10, 921.24, 921.60 or 921.71 ONLY!",$C(7),! G TT

 D NEWCS^PRCFAC G:'$D(DA) KILL

 I PRCFA("EDIT")'["921.71" S DR=$S(PRCFA("EDIT")["921.60":"61",1:"7")_";8;9DELIVERY DATE~;S PRCFA(""DEL"")=Y",DIE="^PRCF(423," D ^DIE I $D(Y)'=0 G KILL

 S PRC("CP")=+$P(PO(0),"^",3) D ^PRCFALD S PRC("CP")=$P($P(PO(0),"^",3)," ")

 S CS=$S($D(^PRCF(423,PRCFA("CSDA"),1)):^(1),1:"") S $P(CS,"^")=PRCFA("YALD"),$P(CS,"^",5,7)=PRC("CP")_"^"_+$P(PO(0),"^",5)_"^^"

 S $P(CS,"^",8,11)=$P(PO(0),"^",6)_"^"_($P(PO(0),"^",7)*100)_"^"_$S($P(PO(0),"^",8)>0:$P(PO(0),"^",8),1:"$")_"^"_$S(+$P(PO(0),"^",9)'=0:$P(PO(0),"^",9)*100,1:""),$P(CS,"^",16)="$",^PRCF(423,PRCFA("CSDA"),1)=CS

 I PRCFA("EDIT")["921.71" S ^PRCF(423,PRCFA("CSDA"),13,0)="^423.11A^2^2" F I=1,2 S X=$S(I=1:6,1:8) S SA=+$P(PO(0),"^",X),AMT=$P(PO(0),"^",X+1)*100,^PRCF(423,PRCFA("CSDA"),13,I,0)=I_"^^^^^"_$S(SA>0:SA,1:"$")_"^^^"_$S(+AMT'=0:AMT,1:"")

 D @($S(PRCFA("EDIT")'["921.71":"^PRCFA921",1:"71^PRCFA921"))

 D ^PRCFACXM I $D(PRCFDEL)!($D(PRCFA("CSHOLD"))) S X="No further processing is being taken on this 1358.  It has NOT been obligated.  Entry in PO file is being deleted.*" D MSG^PRCFQ K PRCFDEL,PRCFA("CSHOLD") G KILL

 D WAIT^PRCFYN,POST G OUT:'%

 S X=100,DA=PRCFA("PODA") D ENF^PRCHSTAT

 S AMT=$P(^PRCF(423,PRCFA("CSDA"),1),"^",9)+$P(^(1),"^",11)*.01 D NOW^PRCFQ S TIME=X

 ;S X=$P(TRNODE(4),"^",8),DA=PRCFA("TRDA") D TRANK^PRCSES S X=$P(PRC("PER"),"^",2) D EN^PRCHUTL

 S X=$P(TRNODE(4),"^",8),DA=PRCFA("TRDA") D TRANK^PRCSES

 S DEL=$S('$D(DEL):"",1:DEL)

 W !,"Updating Code Sheet information",!

 D CS^PRCS58OB(OB,AMT,TIME,PATNUM,PODA,DEL,X,.PRC)

 W !,"Updating 1358 Obligation balances",!

 D BAL^PRCH58OB(PODA,AMT)

 S X=AMT D TRANS1^PRCSES

 S X=AMT D TRANS^PRCSES D BULLET^PRCEFIS1,OUT W !! G V

OUT K DTOUT,DIRUT,DUOUT,DIROUT,P,PRCB,PRCSCOST,PRCSN,PRCST,PRCST1,XMDUZ,XMSUB,XMTEXT,Y,Z

KILL D KILL^PRCH58OB(PODA) G OUT

LOOKUP ;Lookup 1358 transaction which is pending fiscal action.

 N DIC,FSO,TN

 S:'$D(TT) TT="O"

 S DIC=410,DIC(0)="AEMNZ",FSO=$O(^PRCD(442.3,"AC",10,0)),DIC("S")="S TN=^(0) I $P($P(TN,U),""-"",1,2)=PRCF(""SIFY""),TT[$P(TN,U,2),$P(TN,""^"",4)=1,$D(^(10)),$P(^(10),U,4)=FSO"

 D ^PRCSDIC

POST ;post data in file 424

 N X,Z,DAR,DIC,Y,DA,DIE,DR,TIME

 S (X,Z)=PATNUM,%=1 D EN1^PRCSUT3 I +$P(X,"-",3)>1 W $C(7),!,"This is not a new 1358.  Adjustments may only be entered through the",!,"adjustment option." H 3 S %=0 Q

 S DIC=424,DIC(0)="LX",DLAYGO=424 D ^DIC K DLAYGO I Y<0 W !,"ERROR IN CREATING 424 RECORD" S %=0 Q

 S DAR=+Y

 D NOW^%DTC S TIME=%,DIE=DIC,DA=DAR,X=PODA,DR=".02////^S X=PODA;.03////^S X=""O"";.06////^S X=$P(PO(0),U,11);.07////^S X=TIME;.08////^S X=DUZ;1.1///^S X=""INITIAL OBLIGATION"";.15////^S X=OB"

 D ^DIE S %=1

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCEOB   4126     printed  Mar 13, 2025@21:06:19                                                                                                                                                                                                      Page 2

PRCEOB    ;WISC/CLH/CTB-1358 OBLIGATION ; 15 Apr 93  1:02 PM

V         ;;5.1;IFCAP;;Oct 20, 2000

 +1       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +2        KILL PRC,PRCF,Y

 +3        SET PRCF("X")="AB"

           DO ^PRCFSITE

           if '%

               QUIT

 +4        DO LOOKUP

           if Y<0

               GOTO OUT

           KILL DIC,OB,DA,DIR,TRNODE,PCP,IOINHI,IOINLOW,IOINORM,X,PO,PODA,PRCHP,PATNUM,TR3,TR4,PO0,%,MSG

           SET (OB,DA)=+Y

SC         DO NODE^PRCS58OB(DA,.TRNODE)

 +1        SET PRCFA("TRDA")=OB

           DO SCREEN^PRCEOB1

           WRITE !

           SET DIR(0)="Y"

           SET DIR("A")="Is the above information correct"

           SET DIR("B")="YES"

           SET DIR("?")="'NO' will allow you to edit the information, '^' to Exit"

           DO ^DIR

           if $DATA(DIRUT)

               GOTO OUT

 +2        KILL DIR

           if $DATA(DIRUT)

               GOTO OUT

           IF 'Y

               DO OB^PRCS58OB(OB)

               GOTO SC

 +3        SET PCP=$PIECE(TRNODE(0),"-",4)

           SET PQT=$PIECE(TRNODE(0),"-",3)

           DO CPBAL^PRCFAC01

           KILL PQT,PRCF("NOBAL")

           SET DIR(0)="Y"

           SET DIR("A")="OK to continue"

           SET DIR("B")="YES"

           DO ^DIR

           if 'Y!($DATA(DTOUT))

               GOTO OUT

 +4        KILL DA,X

           SET PRCHP("T")=21

           SET PRCHP("S")=4

           SET PRCHP("A")="1358 Obligation Number"

           SET PRCFA(1358)=""

           DO EN^PRCHPAT

           KILL PRCFA(1358),PRCHP

           IF '$DATA(DA)

               SET X="Unable to establish Obligation Number, processing has been terminated.*"

               DO MSG^PRCFQ

               GOTO OUT

 +5        DO OB1^PRCS58OB(OB,DA)

 +6        DO PAT^PRCH58OB(DA,.PODA,.PO,.PATNUM)

 +7        DO COB^PRCH58OB(PODA,.TRNODE,.PO,OB,X)

 +8        NEW PRCFA,PRCFDEL,AMT,CS,DA,DIK,TIME

TT         SET PRCFA("REF")=$PIECE($PIECE(PO(0),"^"),"-",2)

           SET PRCFA("SYS")="CLM"

           SET PRCFA("TT")="921.60"

           DO TT^PRCFAC

           if '%

               GOTO KILL

 +1        IF "921.00921.10921.24921.60921.71"'[PRCFA("TT")

               WRITE " Invalid Transaction Type.Status Code selected. ",!?20,"921.00, 921.10, 921.24, 921.60 or 921.71 ONLY!",$CHAR(7),!

               GOTO TT

 +2        DO NEWCS^PRCFAC

           if '$DATA(DA)

               GOTO KILL

 +3        IF PRCFA("EDIT")'["921.71"

               SET DR=$SELECT(PRCFA("EDIT")["921.60":"61",1:"7")_";8;9DELIVERY DATE~;S PRCFA(""DEL"")=Y"

               SET DIE="^PRCF(423,"

               DO ^DIE

               IF $DATA(Y)'=0

                   GOTO KILL

 +4        SET PRC("CP")=+$PIECE(PO(0),"^",3)

           DO ^PRCFALD

           SET PRC("CP")=$PIECE($PIECE(PO(0),"^",3)," ")

 +5        SET CS=$SELECT($DATA(^PRCF(423,PRCFA("CSDA"),1)):^(1),1:"")

           SET $PIECE(CS,"^")=PRCFA("YALD")

           SET $PIECE(CS,"^",5,7)=PRC("CP")_"^"_+$PIECE(PO(0),"^",5)_"^^"

 +6        SET $PIECE(CS,"^",8,11)=$PIECE(PO(0),"^",6)_"^"_($PIECE(PO(0),"^",7)*100)_"^"_$SELECT($PIECE(PO(0),"^",8)>0:$PIECE(PO(0),"^",8),1:"$")_"^"_$SELECT(+$PIECE(PO(0),"^",9)'=0:$PIECE(PO(0),"^",9)*100,1:"")

           SET $PIECE(CS,"^",16)="$"

           SET ^PRCF(423,PRCFA("CSDA"),1)=CS

 +7        IF PRCFA("EDIT")["921.71"

               SET ^PRCF(423,PRCFA("CSDA"),13,0)="^423.11A^2^2"

               FOR I=1,2

                   SET X=$SELECT(I=1:6,1:8)

                   SET SA=+$PIECE(PO(0),"^",X)

                   SET AMT=$PIECE(PO(0),"^",X+1)*100

                   SET ^PRCF(423,PRCFA("CSDA"),13,I,0)=I_"^^^^^"_$SELECT(SA>0:SA,1:"$")_"^^^"_$SELECT(+AMT'=0:AMT,1:"")

 +8        DO @($SELECT(PRCFA("EDIT")'["921.71":"^PRCFA921",1:"71^PRCFA921"))

 +9        DO ^PRCFACXM

           IF $DATA(PRCFDEL)!($DATA(PRCFA("CSHOLD")))

               SET X="No further processing is being taken on this 1358.  It has NOT been obligated.  Entry in PO file is being deleted.*"

               DO MSG^PRCFQ

               KILL PRCFDEL,PRCFA("CSHOLD")

               GOTO KILL

 +10       DO WAIT^PRCFYN

           DO POST

           if '%

               GOTO OUT

 +11       SET X=100

           SET DA=PRCFA("PODA")

           DO ENF^PRCHSTAT

 +12       SET AMT=$PIECE(^PRCF(423,PRCFA("CSDA"),1),"^",9)+$PIECE(^(1),"^",11)*.01

           DO NOW^PRCFQ

           SET TIME=X

 +13      ;S X=$P(TRNODE(4),"^",8),DA=PRCFA("TRDA") D TRANK^PRCSES S X=$P(PRC("PER"),"^",2) D EN^PRCHUTL

 +14       SET X=$PIECE(TRNODE(4),"^",8)

           SET DA=PRCFA("TRDA")

           DO TRANK^PRCSES

 +15       SET DEL=$SELECT('$DATA(DEL):"",1:DEL)

 +16       WRITE !,"Updating Code Sheet information",!

 +17       DO CS^PRCS58OB(OB,AMT,TIME,PATNUM,PODA,DEL,X,.PRC)

 +18       WRITE !,"Updating 1358 Obligation balances",!

 +19       DO BAL^PRCH58OB(PODA,AMT)

 +20       SET X=AMT

           DO TRANS1^PRCSES

 +21       SET X=AMT

           DO TRANS^PRCSES

           DO BULLET^PRCEFIS1

           DO OUT

           WRITE !!

           GOTO V

OUT        KILL DTOUT,DIRUT,DUOUT,DIROUT,P,PRCB,PRCSCOST,PRCSN,PRCST,PRCST1,XMDUZ,XMSUB,XMTEXT,Y,Z

 +1        QUIT

KILL       DO KILL^PRCH58OB(PODA)

           GOTO OUT

 +1       ;

LOOKUP    ;Lookup 1358 transaction which is pending fiscal action.

 +1        NEW DIC,FSO,TN

 +2        if '$DATA(TT)

               SET TT="O"

 +3        SET DIC=410

           SET DIC(0)="AEMNZ"

           SET FSO=$ORDER(^PRCD(442.3,"AC",10,0))

           SET DIC("S")="S TN=^(0) I $P($P(TN,U),""-"",1,2)=PRCF(""SIFY""),TT[$P(TN,U,2),$P(TN,""^"",4)=1,$D(^(10)),$P(^(10),U,4)=FSO"

 +4        DO ^PRCSDIC

 +5        QUIT

POST      ;post data in file 424

 +1        NEW X,Z,DAR,DIC,Y,DA,DIE,DR,TIME

 +2        SET (X,Z)=PATNUM

           SET %=1

           DO EN1^PRCSUT3

           IF +$PIECE(X,"-",3)>1

               WRITE $CHAR(7),!,"This is not a new 1358.  Adjustments may only be entered through the",!,"adjustment option."

               HANG 3

               SET %=0

               QUIT

 +3        SET DIC=424

           SET DIC(0)="LX"

           SET DLAYGO=424

           DO ^DIC

           KILL DLAYGO

           IF Y<0

               WRITE !,"ERROR IN CREATING 424 RECORD"

               SET %=0

               QUIT

 +4        SET DAR=+Y

 +5        DO NOW^%DTC

           SET TIME=%

           SET DIE=DIC

           SET DA=DAR

           SET X=PODA

           SET DR=".02////^S X=PODA;.03////^S X=""O"";.06////^S X=$P(PO(0),U,11);.07////^S X=TIME;.08////^S X=DUZ;1.1///^S X=""INITIAL OBLIGATION"";.15////^S X=OB"

 +6        DO ^DIE

           SET %=1

 +7        QUIT

PRCEOB.m