PRCFFU41 ;WISC/SJG-FMS DOCUMENT GENERATOR (CONT) ;3/7/95 3:32 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
EN4 ;ENTER DATA INTO STATUS OF FUNDS FILE
K DIC("A") S DIC="^PRC(420,",DR="[PRCB STATUS FUNDS]",DIC(0)="AEMNQ" D ^DIC K DIC("A") I Y>0 S DIE=DIC,DA=+Y D ^DIE
K %,%X,%Y,D,D0,D1,DA,DD,DIC,DIE,DIX,DO,DQ,DR,DZ,J,K,X,Y Q
EN5 ;UPDATE ESTIMATED BALANCE FIELD OF CONTROL POINT FILE
;REQUIRES VARIABLE PRC("SITE")
I '$D(PRC("SITE")) S PRCF("X")="AS" D ^PRCFSITE G:'% OUT5
K DIC("A") W !,$C(7),"REMEMBER, DO NOT ENTER TRANSACTION FOR FUTURE QUARTERS!",!
X S DIC="^PRC(420,"_PRC("SITE")_",1,",DIC(0)="AEQMNZ" D ^DIC K DIC G:'$T!(X[U) OUT5 I Y<0 W $C(7),!!,"I'M CONFUSED ABOUT WHICH CONTROL POINT YOU WANT, TRY AGAIN. ",!,"USE AN '^' TO QUIT",! G X
S PRC("CP")=+Y,PRC("CP",0)=Y(0)
EN51 W !,"ENTER TRANSACTION AMOUNT: " R X:$S($D(DTIME):DTIME,1:60) Q:X="^" I X'?.1"+".1"-".N1"."2N W !,"ENTER AMOUNT OF TRANSACTION, INCLUDING THE DECIMAL POINT",! G EN51
I X<0 S X=-(X)
I X'?.N.1".".2N W $C(7),"??" G EN51
S X1=X
R W !,"(I)ncrease or (D)ecrease to balance? D//" R X:$S($D(DTIME):DTIME,1:300) G:'$T!(X["^") OUT5
S:X="" X="D" I X["?"!(X'["D"&(X'["I")) W !!,"Enter a <CR> or 'D' to DECREASE the balance in the status, an 'I' to INCREASE",!,"the balance, or an '^' to ABORT the option." G R
I X["D" S X1=-(X1)
W !,"THE OLD ESTIMATED BALANCE IS $",$J($P(PRC("CP",0),U,8),0,2) K PRCFX S PRCFX=$P(PRC("CP",0),U,8)+X1
W !,"THE NEW ESTIMATED BALANCE IS $",$J(PRCFX,0,2),!!
S %A="OK TO POST",%B="A 'NO' or '^' will prevent posting action from occurring." S %=1 D ^PRCFYN
I %=1 S $P(^PRC(420,PRC("SITE"),1,PRC("CP"),0),U,8)=PRCFX W !,"POSTED",!!
E W !,"NO ACTION TAKEN! " S %A=" DO YOU WISH TO RE-ENTER DATA",%B="" S %=1 D ^PRCFYN G:%=1 X G OUT5
S DIC("A")="Select Next Control Point Name: " G X
OUT5 K %,DIC,I,J,K,PRCFX,X,X1,Y,Z Q
EN7(XA,XB,XC,XD) ; Post FMS Document information to Purchase Order
; XA - Transaction Type, eg MO,SO
; XB - Document Action, eg E,M,X
; XC - Obligation Processing Date
; XD - PAT Number (w/o Station), eg A51234
EN7A Q:'$D(GECSFMS("DOC")) Q:GECSFMS("DOC")="" Q:PRCFA("SYS")'="FMS"
I '$D(PRCFA("PODA")) Q
S PO=PRCFA("PODA") I '$D(^PRC(442,+PO,0)) Q
S PO(0)=^PRC(442,+PO,0) D NOW^%DTC K %H,%I S (DATE,Y)=% D DD^%DT K PRCFA("CK") I '$D(^PRC(442,+PO,10,0)) S ^PRC(442,+PO,10,0)="^442.09A^0^0"
K DD,DO N GETNUM S GETNUM=$P(^PRC(442,+PO,10,0),U,3)
F S GETNUM=GETNUM+1 Q:$G(^PRC(442,+PO,10,GETNUM,0))=""
S DINUM=GETNUM,DIC(0)="MNL",DLAYGO=442,DIC="^PRC(442,"_+PO_",10,"
EN7B S:XB=0 XB="E" S:XB=1 XB="M"
S XC=$$DATE1^PRCFFU2(XC),X=XA_"."_XB_"."_XC_"."_XD_"."_Y,X=""_X_"" D FILE^DICN K DINUM,DLAYGO,DD,DO Q:Y<1
S MESSAGE=""
EN7C I +PO>0 D
.N PRCCSID S PRCCSID=$P(GECSFMS("DOC"),U,3)_"-"_$P(GECSFMS("DOC"),U,4)
.I $D(GECSFMS("BAT")) S PRCCSID=PRCCSID_"-"_$P(GECSFMS("BAT"),U,3)
.S ^PRC(442,+PO,10,+Y,0)=$P(^PRC(442,+PO,10,+Y,0),U,1)_U_+PRC("PER")_U_U_PRCCSID,PRCFA("PODA")=+PO D:$D(POESIG) ENCODE^PRCHES4(+PO,+Y,+PRC("PER"),.MESSAGE)
.S $P(^PRC(442,+PO,10,+Y,0),U,9)=GECSFMS("DA")
.I $D(PRCFA("TT")) I PRCFA("TT")="SO"!(PRCFA("TT")="AR"),PRCFA("MP")=21,$P(TRNODE(0),U,2)="A" S $P(^PRC(442,+PO,10,+Y,0),U,11)=TRDA
.I $D(PRCFA("TT")) I PRCFA("TT")="SO"!(PRCFA("TT")="AR"),PRCFA("MP")=2,$D(PRCFA("AMEND#")) S $P(^PRC(442,+PO,10,+Y,0),U,10)=PRCFA("AMEND#")
.I $D(PRCFA("TT")) I PRCFA("TT")="MO",$D(PRCFA("AMEND#")) S $P(^PRC(442,+PO,10,+Y,0),U,10)=PRCFA("AMEND#")
EN7D I $D(PRCFA("OBLDATE")) S $P(^PRC(442,+PO,10,+Y,0),U,12)=PRCFA("OBLDATE")
I $D(PRCFA("ACCPD")) S $P(^PRC(442,+PO,10,+Y,0),U,13)=$P(PRCFA("ACCPD"),U,3)
K MESSAGE,POESIG,DATE
Q
EN71 ;MARK PO AS OBLIGATED
;S PTYPE=+$P(^PRC(442,PRCFA("PODA"),0),"^",2),PTYPE=$S($D(^PRCD(442.5,PTYPE,0)):$P(^(0),"^",4),1:"")
;I PTYPE'["Y" S $P(^PRC(442,PRCFA("PODA"),7),U,1)=$O(^PRCD(442.3,"AC",40,0)) K PTYPE Q
;S FSO=$P(^PRC(442,PRCFA("PODA"),7),U,1),FSO=$P(^PRCD(442.3,FSO,0),"^",3)+15,FSO=$O(^PRCD(442.3,"AC",FSO,0)),$P(^PRC(442,PRCFA("PODA"),7),"^",1)=FSO K FSO
Q
EN72 ;MARK PO AS COMPLETE
S FSO=+^PRC(442,PRCFA("PODA"),7),FSO=$P(^PRCD(442.3,FSO,0),"^",3)
I FSO=35!(FSO=36),$D(PRCFA("LIQ")),"CF"[PRCFA("LIQ") S X=FSO+5,DA=PRCFA("PODA") D ENF^PRCHSTAT
I $D(PRCFA("PARTIAL")) S $P(^PRC(442,PRCFA("PODA"),11,PRCFA("PARTIAL"),0),U,6)="Y"
Q
EN73 G EN73^PRCFAC
EN731 G EN731^PRCFAC
EN732 G EN732^PRCFAC
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFFU41 4419 printed Dec 13, 2024@02:03:49 Page 2
PRCFFU41 ;WISC/SJG-FMS DOCUMENT GENERATOR (CONT) ;3/7/95 3:32 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN4 ;ENTER DATA INTO STATUS OF FUNDS FILE
+1 KILL DIC("A")
SET DIC="^PRC(420,"
SET DR="[PRCB STATUS FUNDS]"
SET DIC(0)="AEMNQ"
DO ^DIC
KILL DIC("A")
IF Y>0
SET DIE=DIC
SET DA=+Y
DO ^DIE
+2 KILL %,%X,%Y,D,D0,D1,DA,DD,DIC,DIE,DIX,DO,DQ,DR,DZ,J,K,X,Y
QUIT
EN5 ;UPDATE ESTIMATED BALANCE FIELD OF CONTROL POINT FILE
+1 ;REQUIRES VARIABLE PRC("SITE")
+2 IF '$DATA(PRC("SITE"))
SET PRCF("X")="AS"
DO ^PRCFSITE
if '%
GOTO OUT5
+3 KILL DIC("A")
WRITE !,$CHAR(7),"REMEMBER, DO NOT ENTER TRANSACTION FOR FUTURE QUARTERS!",!
X SET DIC="^PRC(420,"_PRC("SITE")_",1,"
SET DIC(0)="AEQMNZ"
DO ^DIC
KILL DIC
if '$TEST!(X[U)
GOTO OUT5
IF Y<0
WRITE $CHAR(7),!!,"I'M CONFUSED ABOUT WHICH CONTROL POINT YOU WANT, TRY AGAIN. ",!,"USE AN '^' TO QUIT",!
GOTO X
+1 SET PRC("CP")=+Y
SET PRC("CP",0)=Y(0)
EN51 WRITE !,"ENTER TRANSACTION AMOUNT: "
READ X:$SELECT($DATA(DTIME):DTIME,1:60)
if X="^"
QUIT
IF X'?.1"+".1"-".N1"."2N
WRITE !,"ENTER AMOUNT OF TRANSACTION, INCLUDING THE DECIMAL POINT",!
GOTO EN51
+1 IF X<0
SET X=-(X)
+2 IF X'?.N.1".".2N
WRITE $CHAR(7),"??"
GOTO EN51
+3 SET X1=X
R WRITE !,"(I)ncrease or (D)ecrease to balance? D//"
READ X:$SELECT($DATA(DTIME):DTIME,1:300)
if '$TEST!(X["^")
GOTO OUT5
+1 if X=""
SET X="D"
IF X["?"!(X'["D"&(X'["I"))
WRITE !!,"Enter a <CR> or 'D' to DECREASE the balance in the status, an 'I' to INCREASE",!,"the balance, or an '^' to ABORT the option."
GOTO R
+2 IF X["D"
SET X1=-(X1)
+3 WRITE !,"THE OLD ESTIMATED BALANCE IS $",$JUSTIFY($PIECE(PRC("CP",0),U,8),0,2)
KILL PRCFX
SET PRCFX=$PIECE(PRC("CP",0),U,8)+X1
+4 WRITE !,"THE NEW ESTIMATED BALANCE IS $",$JUSTIFY(PRCFX,0,2),!!
+5 SET %A="OK TO POST"
SET %B="A 'NO' or '^' will prevent posting action from occurring."
SET %=1
DO ^PRCFYN
+6 IF %=1
SET $PIECE(^PRC(420,PRC("SITE"),1,PRC("CP"),0),U,8)=PRCFX
WRITE !,"POSTED",!!
+7 IF '$TEST
WRITE !,"NO ACTION TAKEN! "
SET %A=" DO YOU WISH TO RE-ENTER DATA"
SET %B=""
SET %=1
DO ^PRCFYN
if %=1
GOTO X
GOTO OUT5
+8 SET DIC("A")="Select Next Control Point Name: "
GOTO X
OUT5 KILL %,DIC,I,J,K,PRCFX,X,X1,Y,Z
QUIT
EN7(XA,XB,XC,XD) ; Post FMS Document information to Purchase Order
+1 ; XA - Transaction Type, eg MO,SO
+2 ; XB - Document Action, eg E,M,X
+3 ; XC - Obligation Processing Date
+4 ; XD - PAT Number (w/o Station), eg A51234
EN7A if '$DATA(GECSFMS("DOC"))
QUIT
if GECSFMS("DOC")=""
QUIT
if PRCFA("SYS")'="FMS"
QUIT
+1 IF '$DATA(PRCFA("PODA"))
QUIT
+2 SET PO=PRCFA("PODA")
IF '$DATA(^PRC(442,+PO,0))
QUIT
+3 SET PO(0)=^PRC(442,+PO,0)
DO NOW^%DTC
KILL %H,%I
SET (DATE,Y)=%
DO DD^%DT
KILL PRCFA("CK")
IF '$DATA(^PRC(442,+PO,10,0))
SET ^PRC(442,+PO,10,0)="^442.09A^0^0"
+4 KILL DD,DO
NEW GETNUM
SET GETNUM=$PIECE(^PRC(442,+PO,10,0),U,3)
+5 FOR
SET GETNUM=GETNUM+1
if $GET(^PRC(442,+PO,10,GETNUM,0))=""
QUIT
+6 SET DINUM=GETNUM
SET DIC(0)="MNL"
SET DLAYGO=442
SET DIC="^PRC(442,"_+PO_",10,"
EN7B if XB=0
SET XB="E"
if XB=1
SET XB="M"
+1 SET XC=$$DATE1^PRCFFU2(XC)
SET X=XA_"."_XB_"."_XC_"."_XD_"."_Y
SET X=""_X_""
DO FILE^DICN
KILL DINUM,DLAYGO,DD,DO
if Y<1
QUIT
+2 SET MESSAGE=""
EN7C IF +PO>0
Begin DoDot:1
+1 NEW PRCCSID
SET PRCCSID=$PIECE(GECSFMS("DOC"),U,3)_"-"_$PIECE(GECSFMS("DOC"),U,4)
+2 IF $DATA(GECSFMS("BAT"))
SET PRCCSID=PRCCSID_"-"_$PIECE(GECSFMS("BAT"),U,3)
+3 SET ^PRC(442,+PO,10,+Y,0)=$PIECE(^PRC(442,+PO,10,+Y,0),U,1)_U_+PRC("PER")_U_U_PRCCSID
SET PRCFA("PODA")=+PO
if $DATA(POESIG)
DO ENCODE^PRCHES4(+PO,+Y,+PRC("PER"),.MESSAGE)
+4 SET $PIECE(^PRC(442,+PO,10,+Y,0),U,9)=GECSFMS("DA")
+5 IF $DATA(PRCFA("TT"))
IF PRCFA("TT")="SO"!(PRCFA("TT")="AR")
IF PRCFA("MP")=21
IF $PIECE(TRNODE(0),U,2)="A"
SET $PIECE(^PRC(442,+PO,10,+Y,0),U,11)=TRDA
+6 IF $DATA(PRCFA("TT"))
IF PRCFA("TT")="SO"!(PRCFA("TT")="AR")
IF PRCFA("MP")=2
IF $DATA(PRCFA("AMEND#"))
SET $PIECE(^PRC(442,+PO,10,+Y,0),U,10)=PRCFA("AMEND#")
+7 IF $DATA(PRCFA("TT"))
IF PRCFA("TT")="MO"
IF $DATA(PRCFA("AMEND#"))
SET $PIECE(^PRC(442,+PO,10,+Y,0),U,10)=PRCFA("AMEND#")
End DoDot:1
EN7D IF $DATA(PRCFA("OBLDATE"))
SET $PIECE(^PRC(442,+PO,10,+Y,0),U,12)=PRCFA("OBLDATE")
+1 IF $DATA(PRCFA("ACCPD"))
SET $PIECE(^PRC(442,+PO,10,+Y,0),U,13)=$PIECE(PRCFA("ACCPD"),U,3)
+2 KILL MESSAGE,POESIG,DATE
+3 QUIT
EN71 ;MARK PO AS OBLIGATED
+1 ;S PTYPE=+$P(^PRC(442,PRCFA("PODA"),0),"^",2),PTYPE=$S($D(^PRCD(442.5,PTYPE,0)):$P(^(0),"^",4),1:"")
+2 ;I PTYPE'["Y" S $P(^PRC(442,PRCFA("PODA"),7),U,1)=$O(^PRCD(442.3,"AC",40,0)) K PTYPE Q
+3 ;S FSO=$P(^PRC(442,PRCFA("PODA"),7),U,1),FSO=$P(^PRCD(442.3,FSO,0),"^",3)+15,FSO=$O(^PRCD(442.3,"AC",FSO,0)),$P(^PRC(442,PRCFA("PODA"),7),"^",1)=FSO K FSO
+4 QUIT
EN72 ;MARK PO AS COMPLETE
+1 SET FSO=+^PRC(442,PRCFA("PODA"),7)
SET FSO=$PIECE(^PRCD(442.3,FSO,0),"^",3)
+2 IF FSO=35!(FSO=36)
IF $DATA(PRCFA("LIQ"))
IF "CF"[PRCFA("LIQ")
SET X=FSO+5
SET DA=PRCFA("PODA")
DO ENF^PRCHSTAT
+3 IF $DATA(PRCFA("PARTIAL"))
SET $PIECE(^PRC(442,PRCFA("PODA"),11,PRCFA("PARTIAL"),0),U,6)="Y"
+4 QUIT
EN73 GOTO EN73^PRCFAC
EN731 GOTO EN731^PRCFAC
EN732 GOTO EN732^PRCFAC
