PRCEADJ ;WISC/CLH/LDB/PLT/SJG - CP 1358 ADJUSTMENTS ; 9/15/2010
V ;;5.1;IFCAP;**140,148**;Oct 20, 2000;Build 5
;;Per VHA Directive 2004-038, this routine should not be modified.
;Create increase/decrease adjustment
EN N PRC410,PRC442,PRCS,DIE,DR,PRC,PRCS2,DIC,X,X410,X442,X1,X2,X3,X4,PRCSIP,Y,Y410,DIR,TRNODE,Z,Z410,PRCSOBN
EN1 ;
D EN^PRCSUT ; ask site, fiscal year, quarter, control point; set X & Z
I '$D(PRC("SITE")) W !,$C(7),"You are not an authorized control point user.",! G OUT
G OUT:'$D(PRC("QTR"))!(Y<0)
S X410=X ; station-FY-FCP
S Z410=Z ; station-FY-quarter-FCP
;
; warn CP official, allow to quit (PRC*5.1*148)
G:$$Q1358^PRCEN(PRC("SITE"),PRC("CP"),"A") OUT
;
ENA1 S DIC=410,Y=""
D OROBL^PRCS58OB(DIC,.PRC,.Y) ; get obligation # from old 1358
I $D(DTOUT)!$D(DUOUT) G OUT
I Y<0 W $C(7),!!," Obligation number is required. Use '^' to exit this option.",! G ENA1
S Y410=Y
S X442=X
D NODE^PRCS58OB(+Y,.TRNODE) ; set up TRNODE array from data in 410
S X="0101"_$P(TRNODE(0),"-",2),%DT="X" D ^%DT
S X2=$E(Y,1,3) ; FY of original 1358
S X="0101"_PRC("FY"),%DT="X" D ^%DT
S X3=$E(Y,1,3) ; adjustment FY
I X2_"-"_$P(TRNODE(0),"-",3)](X3_"-"_PRC("QTR")) D EN^DDIOL("Adjustments cannot be earlier than the original 1358's FY-QTR.") G ENA1
N POOBL S POOBL=$P($G(TRNODE(10)),U,3)
I POOBL="" D EN^DDIOL(" Obligation number is required.") W ! G ENA1
N OBLSTAT S OBLSTAT=$$NP^PRC0B("^PRC(442,"_POOBL_",",7,1)
I $G(OBLSTAT)=40 D EN^DDIOL(" Adjusting a closed 1358 request is not allowed.") W ! G ENA1
ENA2 N EXIT S EXIT=0
D FMSTAT(POOBL,.FMSDOC,.STATUS)
I $D(STATUS),"AF"'[$E(STATUS,1) D I EXIT D MSG1,OUT G EN1
.Q:STATUS="CALM"
.; S TMP=Y,%X="Y",%Y="TMP(" D %XY^%RCR K %X,%Y ; PRC*5*231 - saves Y earlier
.K MSG W !
.S MSG(1)=" Note that one of the previous documents has not been processed in FMS."
.S MSG(2)=" The adjustment to this 1358 cannot be obligated until the previous"
.S MSG(3)=" document has been processed in FMS.",MSG(5)=" "
.S MSG(6)=" FMS Document: "_FMSDOC,MSG(7)=" Status: "_STATUS
.D EN^DDIOL(.MSG) K MSG
.W ! D PROMPT
.S:Y EXIT=0 I 'Y!($D(DIRUT)) S EXIT=1
.Q
;The following lines commented out by PRC*5*231 - Y doesn't need to be restored
; I $D(STATUS) S:"AF"[$E(STATUS,1)!(STATUS="CALM") EXIT=1
ENA3 ; I $D(EXIT) I 'EXIT S Y=TMP,%X="TMP",%Y="Y(" D %XY^%RCR,MSG2 K TMP,%X,%Y
S PRC442=$P($G(TRNODE(10)),U,3)
S PRCSOBN=$$BAL^PRCH58(PRC442) ; get obligation# from file 442,node 8
I PRCSOBN'=-1 W !," Original Obligation Amount: $ ",$FN($P(PRCSOBN,U),",P",2)
I PRCSOBN'=-1 D
.W ?46,"Service Balance: $ ",$FN((+PRCSOBN-$P(PRCSOBN,U,3)),",P",2),!
.W ?4," Fiscal's 1358 Balance: $ ",$FN(+PRCSOBN-$P(PRCSOBN,U,2),",P",2),!
S Y=Y410,X=X410,X1=X,Z=Z410
D EN1^PRCSUT3 Q:'X S X1=X
D EN2 Q:'$D(X1) S X=X1 ; add data to record in 410
W !,"This transaction is assigned transaction number: ",X
L +^PRCS(410,DA):$S($D(DILOCKTM):DILOCKTM,1:3) I $T=0 D EN^DDIOL("File in use.... Please try again later") D KILL G EN1
I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)) S:$P(^(0),U,11)="Y" PRCS2=1
S PRC410=DA
S PRCSIP=$S($D(PRCSIP):PRCSIP,1:"")
D ADJ^PRCS58OB(DIC,DA,PRCSIP,.X4)
K PRCSOBN
D ADJ1^PRCS58OB(DA,X,Y410)
D ADJ2^PRCS58OB(.PRC,X442,DA)
L -^PRCS(410,DA)
S DIR("A")="Enter another increase/decrease adjustment"
S DIR(0)="YO",DIR("B")="NO"
S DIR("?")="Yes to enter an adjustment, return or '^' to quit"
D ^DIR I Y D KILL G EN1
OUT K DIRUT,DTOUT,DUOUT
KILL K PRC410,PRC442,PRCS,DIE,DR,PRC,PRCSL,PRCS2,DIC,X,X410,X442,X1,X4,PRCSIP,Y,Y410,DIR,TRNODE,Z,Z410,PRCSOBN
K DA,FMSDOC,STATUS,TMP,%DT
QUIT
;
ASK ; entry point from other options
S DIR(0)="YO"
S DIR("A")="Do you want to enter an increase adjustment at this time"
S DIR("B")="NO"
S DIR("?")="Yes to enter an increase adjustment, return or '^' to quit"
D ^DIR I 'Y&'$D(DIRUT) W !!,"No action can be taken with this authorization amount now.",! K DIR Q
K DIR,DIC,X,Y I $D(DIRUT) Q
G EN
;
FMSTAT(POOBL,FMSDOC,STATUS) ; Check status of prior FMS Documents
N LOOP,NODE
S LOOP=0,(FMSDOC,STATUS)=""
F S LOOP=$O(^PRC(442,+POOBL,10,LOOP)) Q:LOOP'>0 D
.S NODE=^PRC(442,+POOBL,10,LOOP,0)
.I $E(NODE,1,2)="SO"!($E(NODE,1,2)="AR") D
..S FMSDOC=$P($G(^PRC(442,+POOBL,10,LOOP,0)),U,4)
..S STATUS=$$STATUS^GECSSGET(FMSDOC)
..Q
.I $E(NODE,1,6)?3N1"."2N S STATUS="CALM"
Q
PROMPT ;
S DIR(0)="Y"
S DIR("A")=" Do you wish to create the adjustment to this 1358"
S DIR("B")="YES"
S DIR("?")=" Enter 'YES' or 'Y' or 'RETURN' to create the adjustment."
S DIR("?",1)=" Enter 'NO' or 'N' or '^' to exit."
D ^DIR K DIR
Q
;
EN2 ;add record in file 410
S DLAYGO=410,DIC="^PRCS(410,",DIC(0)="LXZ" D ^DIC K DLAYGO G:Y<0 W4
EN2A S DA=+Y S:'$D(T(2)) T(2)=""
S PRC("ACC")=$$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY"))
S PRCSAPP=$P(PRC("ACC"),U,11)
S ^PRCS(410,DA,0)=$P(^PRCS(410,DA,0),U)_"^^"_T(2)_"^^"_PRC("SITE")
S $P(^PRCS(410,DA,1),U,6,7)=$P($G(^PRCS(410,+Y410,1)),U,6,7)
S ^PRCS(410,DA,2)=$G(^PRCS(410,+Y410,2))
S ^PRCS(410,DA,3)=PRC("CP")_U_PRCSAPP,$P(^(3),U,12)=$P(PRC("ACC"),U,3)
S $P(^PRCS(410,DA,3),U,11)=$P($$DATE^PRC0C(PRC("BBFY"),"E"),U,7)
S $P(^PRCS(410,DA,3),U,10)=$P($G(^PRCS(410,+Y410,3)),U,10)
S $P(^PRCS(410,DA,11),U,4,5)=$P($G(^PRCS(410,+Y410,11)),U,4,5)
S ^PRCS(410,"AN",$E(PRC("CP"),1,30),DA)=""
D ERS410^PRC0G(DA_"^E")
S:T(2)'="" ^PRCS(410,"H",$E(T(2),1,30),DA)=DUZ,$P(^PRCS(410,DA,11),U,2)=DUZ,^PRCS(410,"K",+$P(PRC("CP")," "),DA)="",$P(^PRCS(410,DA,6),U,4)=+$P(PRC("CP")," ") K PRCSAPP
EN2B S:$D(PRC("SST")) $P(^PRCS(410,DA,0),U,10)=PRC("SST")
D:$D(MYY) ERS410^PRC0G(DA_"^E")
K T(2),MYY
Q
W4 W !!,"Another user is accessing this file... Try later.",$C(7) R:$E(IOST,1,2)="C-" X:5
Q
;
MSG1 W ! D EN^DDIOL(" No further action taken on this adjustment.") W ! Q
MSG2 W ! D EN^DDIOL(" Returning to creating the 1358 adjustment...") W !! Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCEADJ 5983 printed Oct 16, 2024@18:01:58 Page 2
PRCEADJ ;WISC/CLH/LDB/PLT/SJG - CP 1358 ADJUSTMENTS ; 9/15/2010
V ;;5.1;IFCAP;**140,148**;Oct 20, 2000;Build 5
+1 ;;Per VHA Directive 2004-038, this routine should not be modified.
+2 ;Create increase/decrease adjustment
EN NEW PRC410,PRC442,PRCS,DIE,DR,PRC,PRCS2,DIC,X,X410,X442,X1,X2,X3,X4,PRCSIP,Y,Y410,DIR,TRNODE,Z,Z410,PRCSOBN
EN1 ;
+1 ; ask site, fiscal year, quarter, control point; set X & Z
DO EN^PRCSUT
+2 IF '$DATA(PRC("SITE"))
WRITE !,$CHAR(7),"You are not an authorized control point user.",!
GOTO OUT
+3 if '$DATA(PRC("QTR"))!(Y<0)
GOTO OUT
+4 ; station-FY-FCP
SET X410=X
+5 ; station-FY-quarter-FCP
SET Z410=Z
+6 ;
+7 ; warn CP official, allow to quit (PRC*5.1*148)
+8 if $$Q1358^PRCEN(PRC("SITE"),PRC("CP"),"A")
GOTO OUT
+9 ;
ENA1 SET DIC=410
SET Y=""
+1 ; get obligation # from old 1358
DO OROBL^PRCS58OB(DIC,.PRC,.Y)
+2 IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO OUT
+3 IF Y<0
WRITE $CHAR(7),!!," Obligation number is required. Use '^' to exit this option.",!
GOTO ENA1
+4 SET Y410=Y
+5 SET X442=X
+6 ; set up TRNODE array from data in 410
DO NODE^PRCS58OB(+Y,.TRNODE)
+7 SET X="0101"_$PIECE(TRNODE(0),"-",2)
SET %DT="X"
DO ^%DT
+8 ; FY of original 1358
SET X2=$EXTRACT(Y,1,3)
+9 SET X="0101"_PRC("FY")
SET %DT="X"
DO ^%DT
+10 ; adjustment FY
SET X3=$EXTRACT(Y,1,3)
+11 IF X2_"-"_$PIECE(TRNODE(0),"-",3)](X3_"-"_PRC("QTR"))
DO EN^DDIOL("Adjustments cannot be earlier than the original 1358's FY-QTR.")
GOTO ENA1
+12 NEW POOBL
SET POOBL=$PIECE($GET(TRNODE(10)),U,3)
+13 IF POOBL=""
DO EN^DDIOL(" Obligation number is required.")
WRITE !
GOTO ENA1
+14 NEW OBLSTAT
SET OBLSTAT=$$NP^PRC0B("^PRC(442,"_POOBL_",",7,1)
+15 IF $GET(OBLSTAT)=40
DO EN^DDIOL(" Adjusting a closed 1358 request is not allowed.")
WRITE !
GOTO ENA1
ENA2 NEW EXIT
SET EXIT=0
+1 DO FMSTAT(POOBL,.FMSDOC,.STATUS)
+2 IF $DATA(STATUS)
IF "AF"'[$EXTRACT(STATUS,1)
Begin DoDot:1
+3 if STATUS="CALM"
QUIT
+4 ; S TMP=Y,%X="Y",%Y="TMP(" D %XY^%RCR K %X,%Y ; PRC*5*231 - saves Y earlier
+5 KILL MSG
WRITE !
+6 SET MSG(1)=" Note that one of the previous documents has not been processed in FMS."
+7 SET MSG(2)=" The adjustment to this 1358 cannot be obligated until the previous"
+8 SET MSG(3)=" document has been processed in FMS."
SET MSG(5)=" "
+9 SET MSG(6)=" FMS Document: "_FMSDOC
SET MSG(7)=" Status: "_STATUS
+10 DO EN^DDIOL(.MSG)
KILL MSG
+11 WRITE !
DO PROMPT
+12 if Y
SET EXIT=0
IF 'Y!($DATA(DIRUT))
SET EXIT=1
+13 QUIT
End DoDot:1
IF EXIT
DO MSG1
DO OUT
GOTO EN1
+14 ;The following lines commented out by PRC*5*231 - Y doesn't need to be restored
+15 ; I $D(STATUS) S:"AF"[$E(STATUS,1)!(STATUS="CALM") EXIT=1
ENA3 ; I $D(EXIT) I 'EXIT S Y=TMP,%X="TMP",%Y="Y(" D %XY^%RCR,MSG2 K TMP,%X,%Y
+1 SET PRC442=$PIECE($GET(TRNODE(10)),U,3)
+2 ; get obligation# from file 442,node 8
SET PRCSOBN=$$BAL^PRCH58(PRC442)
+3 IF PRCSOBN'=-1
WRITE !," Original Obligation Amount: $ ",$FNUMBER($PIECE(PRCSOBN,U),",P",2)
+4 IF PRCSOBN'=-1
Begin DoDot:1
+5 WRITE ?46,"Service Balance: $ ",$FNUMBER((+PRCSOBN-$PIECE(PRCSOBN,U,3)),",P",2),!
+6 WRITE ?4," Fiscal's 1358 Balance: $ ",$FNUMBER(+PRCSOBN-$PIECE(PRCSOBN,U,2),",P",2),!
End DoDot:1
+7 SET Y=Y410
SET X=X410
SET X1=X
SET Z=Z410
+8 DO EN1^PRCSUT3
if 'X
QUIT
SET X1=X
+9 ; add data to record in 410
DO EN2
if '$DATA(X1)
QUIT
SET X=X1
+10 WRITE !,"This transaction is assigned transaction number: ",X
+11 LOCK +^PRCS(410,DA):$SELECT($DATA(DILOCKTM):DILOCKTM,1:3)
IF $TEST=0
DO EN^DDIOL("File in use.... Please try again later")
DO KILL
GOTO EN1
+12 IF $DATA(^PRC(420,PRC("SITE"),1,+PRC("CP"),0))
if $PIECE(^(0),U,11)="Y"
SET PRCS2=1
+13 SET PRC410=DA
+14 SET PRCSIP=$SELECT($DATA(PRCSIP):PRCSIP,1:"")
+15 DO ADJ^PRCS58OB(DIC,DA,PRCSIP,.X4)
+16 KILL PRCSOBN
+17 DO ADJ1^PRCS58OB(DA,X,Y410)
+18 DO ADJ2^PRCS58OB(.PRC,X442,DA)
+19 LOCK -^PRCS(410,DA)
+20 SET DIR("A")="Enter another increase/decrease adjustment"
+21 SET DIR(0)="YO"
SET DIR("B")="NO"
+22 SET DIR("?")="Yes to enter an adjustment, return or '^' to quit"
+23 DO ^DIR
IF Y
DO KILL
GOTO EN1
OUT KILL DIRUT,DTOUT,DUOUT
KILL KILL PRC410,PRC442,PRCS,DIE,DR,PRC,PRCSL,PRCS2,DIC,X,X410,X442,X1,X4,PRCSIP,Y,Y410,DIR,TRNODE,Z,Z410,PRCSOBN
+1 KILL DA,FMSDOC,STATUS,TMP,%DT
+2 QUIT
+3 ;
ASK ; entry point from other options
+1 SET DIR(0)="YO"
+2 SET DIR("A")="Do you want to enter an increase adjustment at this time"
+3 SET DIR("B")="NO"
+4 SET DIR("?")="Yes to enter an increase adjustment, return or '^' to quit"
+5 DO ^DIR
IF 'Y&'$DATA(DIRUT)
WRITE !!,"No action can be taken with this authorization amount now.",!
KILL DIR
QUIT
+6 KILL DIR,DIC,X,Y
IF $DATA(DIRUT)
QUIT
+7 GOTO EN
+8 ;
FMSTAT(POOBL,FMSDOC,STATUS) ; Check status of prior FMS Documents
+1 NEW LOOP,NODE
+2 SET LOOP=0
SET (FMSDOC,STATUS)=""
+3 FOR
SET LOOP=$ORDER(^PRC(442,+POOBL,10,LOOP))
if LOOP'>0
QUIT
Begin DoDot:1
+4 SET NODE=^PRC(442,+POOBL,10,LOOP,0)
+5 IF $EXTRACT(NODE,1,2)="SO"!($EXTRACT(NODE,1,2)="AR")
Begin DoDot:2
+6 SET FMSDOC=$PIECE($GET(^PRC(442,+POOBL,10,LOOP,0)),U,4)
+7 SET STATUS=$$STATUS^GECSSGET(FMSDOC)
+8 QUIT
End DoDot:2
+9 IF $EXTRACT(NODE,1,6)?3N1"."2N
SET STATUS="CALM"
End DoDot:1
+10 QUIT
PROMPT ;
+1 SET DIR(0)="Y"
+2 SET DIR("A")=" Do you wish to create the adjustment to this 1358"
+3 SET DIR("B")="YES"
+4 SET DIR("?")=" Enter 'YES' or 'Y' or 'RETURN' to create the adjustment."
+5 SET DIR("?",1)=" Enter 'NO' or 'N' or '^' to exit."
+6 DO ^DIR
KILL DIR
+7 QUIT
+8 ;
EN2 ;add record in file 410
+1 SET DLAYGO=410
SET DIC="^PRCS(410,"
SET DIC(0)="LXZ"
DO ^DIC
KILL DLAYGO
if Y<0
GOTO W4
EN2A SET DA=+Y
if '$DATA(T(2))
SET T(2)=""
+1 SET PRC("ACC")=$$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY"))
+2 SET PRCSAPP=$PIECE(PRC("ACC"),U,11)
+3 SET ^PRCS(410,DA,0)=$PIECE(^PRCS(410,DA,0),U)_"^^"_T(2)_"^^"_PRC("SITE")
+4 SET $PIECE(^PRCS(410,DA,1),U,6,7)=$PIECE($GET(^PRCS(410,+Y410,1)),U,6,7)
+5 SET ^PRCS(410,DA,2)=$GET(^PRCS(410,+Y410,2))
+6 SET ^PRCS(410,DA,3)=PRC("CP")_U_PRCSAPP
SET $PIECE(^(3),U,12)=$PIECE(PRC("ACC"),U,3)
+7 SET $PIECE(^PRCS(410,DA,3),U,11)=$PIECE($$DATE^PRC0C(PRC("BBFY"),"E"),U,7)
+8 SET $PIECE(^PRCS(410,DA,3),U,10)=$PIECE($GET(^PRCS(410,+Y410,3)),U,10)
+9 SET $PIECE(^PRCS(410,DA,11),U,4,5)=$PIECE($GET(^PRCS(410,+Y410,11)),U,4,5)
+10 SET ^PRCS(410,"AN",$EXTRACT(PRC("CP"),1,30),DA)=""
+11 DO ERS410^PRC0G(DA_"^E")
+12 if T(2)'=""
SET ^PRCS(410,"H",$EXTRACT(T(2),1,30),DA)=DUZ
SET $PIECE(^PRCS(410,DA,11),U,2)=DUZ
SET ^PRCS(410,"K",+$PIECE(PRC("CP")," "),DA)=""
SET $PIECE(^PRCS(410,DA,6),U,4)=+$PIECE(PRC("CP")," ")
KILL PRCSAPP
EN2B if $DATA(PRC("SST"))
SET $PIECE(^PRCS(410,DA,0),U,10)=PRC("SST")
+1 if $DATA(MYY)
DO ERS410^PRC0G(DA_"^E")
+2 KILL T(2),MYY
+3 QUIT
W4 WRITE !!,"Another user is accessing this file... Try later.",$CHAR(7)
if $EXTRACT(IOST,1,2)="C-"
READ X:5
+1 QUIT
+2 ;
MSG1 WRITE !
DO EN^DDIOL(" No further action taken on this adjustment.")
WRITE !
QUIT
MSG2 WRITE !
DO EN^DDIOL(" Returning to creating the 1358 adjustment...")
WRITE !!
QUIT
