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
Q
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
Q
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCEOB 4126 printed Dec 13, 2024@02:01:31 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
