- 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 Feb 18, 2025@23:27:35 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