- PRCFAC1 ;WISC@ALTOONA/CTB-CODE SHEET GENERATOR (CONT) ;7/27/94 2:25 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 ;POST CODE SHEET INFORMATION TO PURCHASE ORDER
- Q:'$D(PRCFA("CSDA")) Q:PRCFA("CSDA")="" Q:'$D(^PRCF(423,PRCFA("CSDA"),0)) Q:$P(^(0),"^",10)'="CLM"
- 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"
- S DIC(0)="MNL",DLAYGO=442,DIC="^PRC(442,"_+PO_",10,",X=$S(PRCFCS(0)["$":$P($P(PRCFCS(0),"$",1),".",3,6)_Y,1:$P(PRCFCS(0),".",3,6)_"."_Y) D ^DIC K DLAYGO Q:Y<1
- S MESSAGE=""
- I +PO>0 S ^PRC(442,+PO,10,+Y,0)=$P(^PRC(442,+PO,10,+Y,0),U,1)_U_$P(Q(0),U,8)_U_U_PRCFA("CSDA"),PRCFA("PODA")=+PO D:$D(POESIG) ENCODE^PRCHES4(+PO,+Y,DUZ,.MESSAGE)
- K MESSAGE
- K 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=+$P($G(^PRC(442,PRCFA("PODA"),7)),"^",4)
- S FSO=$P($G(^PRCD(442.3,FSO,0)),"^",3)
- ;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[HPRCFAC1 3476 printed Jan 18, 2025@03:03:03 Page 2
- PRCFAC1 ;WISC@ALTOONA/CTB-CODE SHEET GENERATOR (CONT) ;7/27/94 2:25 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 ;POST CODE SHEET INFORMATION TO PURCHASE ORDER
- +1 if '$DATA(PRCFA("CSDA"))
- QUIT
- if PRCFA("CSDA")=""
- QUIT
- if '$DATA(^PRCF(423,PRCFA("CSDA"),0))
- QUIT
- if $PIECE(^(0),"^",10)'="CLM"
- QUIT
- +2 IF '$DATA(PRCFA("PODA"))
- QUIT
- +3 SET PO=PRCFA("PODA")
- IF '$DATA(^PRC(442,+PO,0))
- QUIT
- +4 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"
- +5 SET DIC(0)="MNL"
- SET DLAYGO=442
- SET DIC="^PRC(442,"_+PO_",10,"
- SET X=$SELECT(PRCFCS(0)["$":$PIECE($PIECE(PRCFCS(0),"$",1),".",3,6)_Y,1:$PIECE(PRCFCS(0),".",3,6)_"."_Y)
- DO ^DIC
- KILL DLAYGO
- if Y<1
- QUIT
- +6 SET MESSAGE=""
- +7 IF +PO>0
- SET ^PRC(442,+PO,10,+Y,0)=$PIECE(^PRC(442,+PO,10,+Y,0),U,1)_U_$PIECE(Q(0),U,8)_U_U_PRCFA("CSDA")
- SET PRCFA("PODA")=+PO
- if $DATA(POESIG)
- DO ENCODE^PRCHES4(+PO,+Y,DUZ,.MESSAGE)
- +8 KILL MESSAGE
- +9 KILL POESIG,DATE
- 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=+$PIECE($GET(^PRC(442,PRCFA("PODA"),7)),"^",4)
- +2 SET FSO=$PIECE($GET(^PRCD(442.3,FSO,0)),"^",3)
- +3 ;S FSO=+^PRC(442,PRCFA("PODA"),7),FSO=$P(^PRCD(442.3,FSO,0),"^",3)
- +4 IF FSO=35!(FSO=36)
- IF $DATA(PRCFA("LIQ"))
- IF "CF"[PRCFA("LIQ")
- SET X=FSO+5
- SET DA=PRCFA("PODA")
- DO ENF^PRCHSTAT
- +5 IF $DATA(PRCFA("PARTIAL"))
- SET $PIECE(^PRC(442,PRCFA("PODA"),11,PRCFA("PARTIAL"),0),U,6)="Y"
- +6 QUIT
- EN73 GOTO EN73^PRCFAC
- EN731 GOTO EN731^PRCFAC
- EN732 GOTO EN732^PRCFAC