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 Apr 09, 2024@21:03:05 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
