- PRCSEM ;WISC/KMB-DELIVERY RECEIVING,OBLIGATION DATA ;6-6-95 12:00
- V ;;5.1;IFCAP;**148**;Oct 20, 2000;Build 5
- ;Per VHA Directive 2004-038, this routine should not be modified.
- S PRCSEM=1 D EDTD^PRCSEB0 K PRCSEM
- ;
- Q
- ENOD ;ENTER OBLIGATION DATA
- ; The option to execute this entry (Obligation Data [PRCSENOD]) was
- ; was removed with PRC*5.1*148 to enforce segregation of duties. This
- ; entry point should no longer be used.
- W !!,"This option is no longer available!" Q
- ;
- D EN3^PRCSUT G W2:'$D(PRC("SITE")),EXIT:Y<0
- S DIC="^PRCS(410,",DIE=DIC,DIC(0)="AEQM",DIC("S")="I +^(0),$D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),""^"",5)=PRC(""SITE""),$P(^(0),""^"",2)=""O"" I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
- D ^PRCSDIC G EXIT:Y<0 K DIC("S") S (DA,PRCS)=+Y L +^PRCS(410,DA):5 G ENOD:$T=0
- ENOD1 ;
- N VALUE,OBLAMT1 S VALUE=$P(^PRCS(410,DA,0),"^") I $D(^PRCS(410,DA,4)),$P(^(4),"^",3)>0 S OBLAMT1=$P(^(4),"^",3)
- W !,"Committed (Estimated) Cost:" I $D(^PRCS(410,DA,4)),$P(^(4),U)]"" W ?28,$J($P(^(4),U),0,2)
- E W ?28,"None entered."
- S DR="[PRCSENOD]",DIE=DIC D ^DIE
- I $D(^PRCS(410,DA,4)),$P(^(4),"^",3)>0 D:$P(^(4),"^",10)]"" REMOVE^PRCSC2(DA) D ENCODE^PRCSC2(DA,DUZ),ERS410^PRC0G(DA_"^O")
- S:'$D(PRCS) PRCS=DA L -^PRCS(410,DA)
- N OBLAMT2 I $D(^PRCS(410,DA,4)),$P(^(4),"^",3)>0 S OBLAMT2=$P(^(4),"^",3)
- I $D(OBLAMT1),$D(OBLAMT2),OBLAMT2<OBLAMT1 D SENDIT
- D W3 G EXIT:%'=1 W !! G ENOD
- SENDIT ;
- N XX,XMY,XMDUZ,XMSUB,XMTEXT S XX=$P($G(^PRCS(410,DA,7)),"^",1) S:XX="" XX=$P($G(^PRCS(410,DA,7)),"^",3) Q:XX=""
- S XMDUZ=DUZ,XMY(XX)=""
- S XMSUB="OBLIGATION DECREASE NOTIFICATION"
- N ARRAY S ARRAY(1)="The obligation amount for transaction "_VALUE,ARRAY(2)="has been decreased from $"_OBLAMT1_" to $"_OBLAMT2_"."
- S XMTEXT="ARRAY(" D ^XMD Q
- W2 W !!,"You are not an authorized control point user.",!,"Contact your control point official." R X:5 G EXIT
- W3 W !!,"Would you like to enter another obligation" S %=1 D YN^DICN G W3:%=0 Q
- EXIT K DA,DIC,DIE,DR,PRCS,PRCS58,PRCSL,T,X,X1,Y,DLAYGO Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSEM 2039 printed Mar 13, 2025@21:22:26 Page 2
- PRCSEM ;WISC/KMB-DELIVERY RECEIVING,OBLIGATION DATA ;6-6-95 12:00
- V ;;5.1;IFCAP;**148**;Oct 20, 2000;Build 5
- +1 ;Per VHA Directive 2004-038, this routine should not be modified.
- +2 SET PRCSEM=1
- DO EDTD^PRCSEB0
- KILL PRCSEM
- +3 ;
- +4 QUIT
- ENOD ;ENTER OBLIGATION DATA
- +1 ; The option to execute this entry (Obligation Data [PRCSENOD]) was
- +2 ; was removed with PRC*5.1*148 to enforce segregation of duties. This
- +3 ; entry point should no longer be used.
- +4 WRITE !!,"This option is no longer available!"
- QUIT
- +5 ;
- +6 DO EN3^PRCSUT
- if '$DATA(PRC("SITE"))
- GOTO W2
- if Y<0
- GOTO EXIT
- +7 SET DIC="^PRCS(410,"
- SET DIE=DIC
- SET DIC(0)="AEQM"
- SET DIC("S")="I +^(0),$D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),""^"",5)=PRC(""SITE""),$P(^(0),""^"",2)=""O"" I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
- +8 DO ^PRCSDIC
- if Y<0
- GOTO EXIT
- KILL DIC("S")
- SET (DA,PRCS)=+Y
- LOCK +^PRCS(410,DA):5
- if $TEST=0
- GOTO ENOD
- ENOD1 ;
- +1 NEW VALUE,OBLAMT1
- SET VALUE=$PIECE(^PRCS(410,DA,0),"^")
- IF $DATA(^PRCS(410,DA,4))
- IF $PIECE(^(4),"^",3)>0
- SET OBLAMT1=$PIECE(^(4),"^",3)
- +2 WRITE !,"Committed (Estimated) Cost:"
- IF $DATA(^PRCS(410,DA,4))
- IF $PIECE(^(4),U)]""
- WRITE ?28,$JUSTIFY($PIECE(^(4),U),0,2)
- +3 IF '$TEST
- WRITE ?28,"None entered."
- +4 SET DR="[PRCSENOD]"
- SET DIE=DIC
- DO ^DIE
- +5 IF $DATA(^PRCS(410,DA,4))
- IF $PIECE(^(4),"^",3)>0
- if $PIECE(^(4),"^",10)]""
- DO REMOVE^PRCSC2(DA)
- DO ENCODE^PRCSC2(DA,DUZ)
- DO ERS410^PRC0G(DA_"^O")
- +6 if '$DATA(PRCS)
- SET PRCS=DA
- LOCK -^PRCS(410,DA)
- +7 NEW OBLAMT2
- IF $DATA(^PRCS(410,DA,4))
- IF $PIECE(^(4),"^",3)>0
- SET OBLAMT2=$PIECE(^(4),"^",3)
- +8 IF $DATA(OBLAMT1)
- IF $DATA(OBLAMT2)
- IF OBLAMT2<OBLAMT1
- DO SENDIT
- +9 DO W3
- if %'=1
- GOTO EXIT
- WRITE !!
- GOTO ENOD
- SENDIT ;
- +1 NEW XX,XMY,XMDUZ,XMSUB,XMTEXT
- SET XX=$PIECE($GET(^PRCS(410,DA,7)),"^",1)
- if XX=""
- SET XX=$PIECE($GET(^PRCS(410,DA,7)),"^",3)
- if XX=""
- QUIT
- +2 SET XMDUZ=DUZ
- SET XMY(XX)=""
- +3 SET XMSUB="OBLIGATION DECREASE NOTIFICATION"
- +4 NEW ARRAY
- SET ARRAY(1)="The obligation amount for transaction "_VALUE
- SET ARRAY(2)="has been decreased from $"_OBLAMT1_" to $"_OBLAMT2_"."
- +5 SET XMTEXT="ARRAY("
- DO ^XMD
- QUIT
- W2 WRITE !!,"You are not an authorized control point user.",!,"Contact your control point official."
- READ X:5
- GOTO EXIT
- W3 WRITE !!,"Would you like to enter another obligation"
- SET %=1
- DO YN^DICN
- if %=0
- GOTO W3
- QUIT
- EXIT KILL DA,DIC,DIE,DR,PRCS,PRCS58,PRCSL,T,X,X1,Y,DLAYGO
- QUIT
