- PRCHSF1 ;WISC/DJM-UPDATES OR PLACES BOCS & AMOUNTS INTO PO FILE AFTER AMENDMENT ;2/16/95 3:42 PM
- V ;;5.1;IFCAP;**120**;Oct 20, 2000;Build 27
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;AMENDED PO
- ;UPDATES TOTAL $ AMOUNTS
- ;CALLED FROM 443.6 COPY ROUTINE 'PRCHAMYB'
- Q:$P(^PRC(442,DA,7),U,1)=45 L +^PRC(442,DA):1 I '$T W !," P.O. is being edited by another person !",$C(7) Q
- S U="^",X=^PRC(442,DA,0),PRCHS("EST")=+$P(X,U,13),PRCHS("CP")=+$P(X,U,3),PRCHS("SITE")=+X I $D(^PRC(420,PRCHS("SITE"),1,PRCHS("CP"),0)),$P(^(0),U,12) S PRCHS("SP")=$P(^(0),U,12)
- S I=0 F S I=$O(^PRC(442,DA,2,I)) Q:I=""!(I'>0) S PRCHS=I,PRCHS("N")=^(PRCHS,0),PRCHS("N2")=$G(^(2)),PRCHS("NS")=+$P(PRCHS("N"),U,4) D L
- S (CNT,J)=0 F S J=$O(PRCHS("A",J)) Q:J=""!(J<0) D LI2
- S (PRCHS("TOT"),PRCHS("NET"),M,PRCHS)=0
- S BOCSHP=$G(^PRC(442,DA,23)),PRCHS(991)=+BOCSHP_"^"_PRCHS("EST") K BOCSHP
- F S M=$O(PRCHS(M)) Q:M=""!(M'>0) I M'=991 S PRCHS("TOT")=PRCHS("TOT")+$P(PRCHS(M),U,2)
- S PO=PRCHPO,PRC("BBFY")=$$BBFY^PRCFFU5(PRCHPO)
- N PARAM K PRCHMO S PARAM=PRCHS("CP")_"^"_PRC("FY")_"^"_PRCFA("BBFY")
- S PRCHMO=$$ACC^PRC0C(PRC("SITE"),PARAM)
- S PRCHS("G/N")=$P(PRCHMO,U,12) K PRCHMO
- I $D(PRCHS("G/N")) D:PRCHS("G/N")="G" LABEL,NET,UPDTN D:PRCHS("G/N")="N" NET,UPDTN,LABEL
- G ^PRCHSF2
- NET ;APPLY PROMPT PAY DISCNT ONLY TO NET FUNDS, & REFLECT NET AMT ON 0 NODE
- D TM S PTM=0 F S PTM=$O(PRCHS(PTM)) Q:(PTM="")!(PTM'>0) I $P(PRCHS(PTM),U,2) I PTM'=991 S X=$P(PRCHS(PTM),U,2),$P(PRCHS(PTM),U,2)=(X-$J(X*PRCHS("T"),0,2)),PRCHS("NET")=PRCHS("NET")+$P(PRCHS(PTM),U,2)
- Q
- ;
- UPDTN ;UPDATE ZERO NODE, CHECK MESSAGE, ELECTRONIC SIGNATURE ETC.
- S PRCHS("NET")=PRCHS("NET")+PRCHS("EST"),PRCHS("TOT")=PRCHS("TOT")+PRCHS("EST"),$P(^PRC(442,DA,0),U,6,9)="^^^"
- S $P(^PRC(442,DA,0),U,15,16)=PRCHS("TOT")_"^"_PRCHS("NET")
- ;NOW UPDATE THE 'AMOUNT CHANGED' FIELD
- ;PRCHTOTQ = THE TOTAL AMOUNT OF THE PO BEFORE THIS UPDATE
- ;PRCHTOTQ IS SET IN ROUTINE 'PRCHAMYA'
- S PRCHS("TOTN")=PRCHS("TOT")-PRCHTOTQ,$P(^PRC(442,PRCHPO,6,PRCHAM,0),U,3)=PRCHS("TOTN"),MESSAGE=""
- D RECODE^PRCHES6(PRCHPO,PRCHAM,.MESSAGE)
- S MESS1=MESSAGE,MESSAGE=1
- ;PRC*5.1*120 added check (AUTOOBLG set in PRCHSWCH) to also skip record recode if EDI or All/DELIVERY ORDER auto obligated order
- I $G(PRCHS("SP"))'=2,$P(^PRC(442,DA,0),U,2)'=25,$G(AUTOOBLG)'=1 D RECODE^PRCHES7(PRCHPO,PRCHAM,.MESSAGE)
- I MESS1'=1!(MESSAGE'=1) W !,"An error has occurred while recoding an ESIG."
- Q
- LABEL ;
- S (CTR,I)=0 F S I=$O(PRCHS(I)) Q:I'>0 D IT
- Q
- ;
- IT N DA S:$D(DA(1)) PRCHDA1=DA(1) S DA(1)=PRCHPO
- S BOC=$P(PRCHS(I),U),AMT=$P(PRCHS(I),U,2),DA=0
- IT1 ;LOOK FOR BOC
- ;IF FOUND
- ; 1, SEE IF FMS LINE NUMBER=991 & I FROM PRCHS(I)=991
- ; A, IF SO, ENTER AMT AND QUIT
- ; 2, SEE IF FMS LINE NUMBER'=991 & I '=991
- ; A, IF SO, ENTER AMT AND QUIT
- S DA=$O(^PRC(442,DA(1),22,"B",+BOC,DA)),FLAGOK=""
- I DA>0 D G:FLAGOK="" IT1 Q
- .S UPDT=$G(^PRC(442,DA(1),22,DA,0)),LINO=$P(UPDT,U,3)
- .I LINO=991,(I=991) S $P(UPDT,U,2)=AMT,^PRC(442,DA(1),22,DA,0)=UPDT,FLAGOK=1 Q
- .I LINO'=991,(I'=991) S $P(UPDT,U,2)=AMT,^PRC(442,DA(1),22,DA,0)=UPDT,FLAGOK=1 Q
- .Q
- ;IF YOU ARRIVED HERE & I=991 YOU NEED TO FIND THE IEN IN NODE 22
- ;THAT HAS AN FMS LINE NUMBER = 991.
- ;WHEN FOUND ENTER BOC & AMT FROM LINE IT+1 AND QUIT.
- I I=991 D Q:FLAGOK=1
- .S DA=0 F S DA=$O(^PRC(442,DA(1),22,DA)) Q:DA'>0 D Q:FLAGOK=1
- ..S UPDT=$G(^PRC(442,DA(1),22,DA,0)),LINO=$P(UPDT,U,3)
- ..I LINO=991 S $P(UPDT,U)=BOC,$P(UPDT,U,2)=AMT,^PRC(442,DA(1),22,DA,0)=UPDT,FLAGOK=1 Q
- .Q
- S DIC="^PRC(442,"_DA(1)_",22,",DIC(0)="L",X=+BOC K DD,DO D FILE^DICN I Y'>0 W !," ERROR " Q
- N DA S DIE=DIC,DA=+Y
- S LAST=LAST+1
- S DR="1////^S X=AMT;2////^S X=LAST" D ^DIE K X,Y,DIE,DIC
- S:$D(PRCHDA1) DA(1)=PRCHDA1 K PRCHDA1
- Q
- ;
- L S:'$D(PRCHS("A",PRCHS("NS"))) PRCHS("A",PRCHS("NS"))="" S LICOST=+$P(PRCHS("N2"),U,1),PRCHS("A",PRCHS("NS"))=+(PRCHS("A",PRCHS("NS")))+LICOST-$P(PRCHS("N2"),U,6)
- Q
- ;
- LI2 S CNT=CNT+1 S PRCHS(CNT)=J_U_PRCHS("A",J) K PRCHS("A",J)
- Q
- ;
- TM ;
- S PRCHS("T")=0,I=0 F S I=$O(^PRC(442,DA,5,I)) Q:'I S X=^(I,0) I +X>0 S I(100-X)=+X
- S:$O(I(0)) PRCHS("T")=I($O(I(0))),PRCHS("T")=PRCHS("T")/100 K I Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHSF1 4192 printed Feb 18, 2025@23:37:03 Page 2
- PRCHSF1 ;WISC/DJM-UPDATES OR PLACES BOCS & AMOUNTS INTO PO FILE AFTER AMENDMENT ;2/16/95 3:42 PM
- V ;;5.1;IFCAP;**120**;Oct 20, 2000;Build 27
- +1 ;Per VHA Directive 2004-038, this routine should not be modified.
- +2 ;AMENDED PO
- +3 ;UPDATES TOTAL $ AMOUNTS
- +4 ;CALLED FROM 443.6 COPY ROUTINE 'PRCHAMYB'
- +5 if $PIECE(^PRC(442,DA,7),U,1)=45
- QUIT
- LOCK +^PRC(442,DA):1
- IF '$TEST
- WRITE !," P.O. is being edited by another person !",$CHAR(7)
- QUIT
- +6 SET U="^"
- SET X=^PRC(442,DA,0)
- SET PRCHS("EST")=+$PIECE(X,U,13)
- SET PRCHS("CP")=+$PIECE(X,U,3)
- SET PRCHS("SITE")=+X
- IF $DATA(^PRC(420,PRCHS("SITE"),1,PRCHS("CP"),0))
- IF $PIECE(^(0),U,12)
- SET PRCHS("SP")=$PIECE(^(0),U,12)
- +7 SET I=0
- FOR
- SET I=$ORDER(^PRC(442,DA,2,I))
- if I=""!(I'>0)
- QUIT
- SET PRCHS=I
- SET PRCHS("N")=^(PRCHS,0)
- SET PRCHS("N2")=$GET(^(2))
- SET PRCHS("NS")=+$PIECE(PRCHS("N"),U,4)
- DO L
- +8 SET (CNT,J)=0
- FOR
- SET J=$ORDER(PRCHS("A",J))
- if J=""!(J<0)
- QUIT
- DO LI2
- +9 SET (PRCHS("TOT"),PRCHS("NET"),M,PRCHS)=0
- +10 SET BOCSHP=$GET(^PRC(442,DA,23))
- SET PRCHS(991)=+BOCSHP_"^"_PRCHS("EST")
- KILL BOCSHP
- +11 FOR
- SET M=$ORDER(PRCHS(M))
- if M=""!(M'>0)
- QUIT
- IF M'=991
- SET PRCHS("TOT")=PRCHS("TOT")+$PIECE(PRCHS(M),U,2)
- +12 SET PO=PRCHPO
- SET PRC("BBFY")=$$BBFY^PRCFFU5(PRCHPO)
- +13 NEW PARAM
- KILL PRCHMO
- SET PARAM=PRCHS("CP")_"^"_PRC("FY")_"^"_PRCFA("BBFY")
- +14 SET PRCHMO=$$ACC^PRC0C(PRC("SITE"),PARAM)
- +15 SET PRCHS("G/N")=$PIECE(PRCHMO,U,12)
- KILL PRCHMO
- +16 IF $DATA(PRCHS("G/N"))
- if PRCHS("G/N")="G"
- DO LABEL
- DO NET
- DO UPDTN
- if PRCHS("G/N")="N"
- DO NET
- DO UPDTN
- DO LABEL
- +17 GOTO ^PRCHSF2
- NET ;APPLY PROMPT PAY DISCNT ONLY TO NET FUNDS, & REFLECT NET AMT ON 0 NODE
- +1 DO TM
- SET PTM=0
- FOR
- SET PTM=$ORDER(PRCHS(PTM))
- if (PTM="")!(PTM'>0)
- QUIT
- IF $PIECE(PRCHS(PTM),U,2)
- IF PTM'=991
- SET X=$PIECE(PRCHS(PTM),U,2)
- SET $PIECE(PRCHS(PTM),U,2)=(X-$JUSTIFY(X*PRCHS("T"),0,2))
- SET PRCHS("NET")=PRCHS("NET")+$PIECE(PRCHS(PTM),U,2)
- +2 QUIT
- +3 ;
- UPDTN ;UPDATE ZERO NODE, CHECK MESSAGE, ELECTRONIC SIGNATURE ETC.
- +1 SET PRCHS("NET")=PRCHS("NET")+PRCHS("EST")
- SET PRCHS("TOT")=PRCHS("TOT")+PRCHS("EST")
- SET $PIECE(^PRC(442,DA,0),U,6,9)="^^^"
- +2 SET $PIECE(^PRC(442,DA,0),U,15,16)=PRCHS("TOT")_"^"_PRCHS("NET")
- +3 ;NOW UPDATE THE 'AMOUNT CHANGED' FIELD
- +4 ;PRCHTOTQ = THE TOTAL AMOUNT OF THE PO BEFORE THIS UPDATE
- +5 ;PRCHTOTQ IS SET IN ROUTINE 'PRCHAMYA'
- +6 SET PRCHS("TOTN")=PRCHS("TOT")-PRCHTOTQ
- SET $PIECE(^PRC(442,PRCHPO,6,PRCHAM,0),U,3)=PRCHS("TOTN")
- SET MESSAGE=""
- +7 DO RECODE^PRCHES6(PRCHPO,PRCHAM,.MESSAGE)
- +8 SET MESS1=MESSAGE
- SET MESSAGE=1
- +9 ;PRC*5.1*120 added check (AUTOOBLG set in PRCHSWCH) to also skip record recode if EDI or All/DELIVERY ORDER auto obligated order
- +10 IF $GET(PRCHS("SP"))'=2
- IF $PIECE(^PRC(442,DA,0),U,2)'=25
- IF $GET(AUTOOBLG)'=1
- DO RECODE^PRCHES7(PRCHPO,PRCHAM,.MESSAGE)
- +11 IF MESS1'=1!(MESSAGE'=1)
- WRITE !,"An error has occurred while recoding an ESIG."
- +12 QUIT
- LABEL ;
- +1 SET (CTR,I)=0
- FOR
- SET I=$ORDER(PRCHS(I))
- if I'>0
- QUIT
- DO IT
- +2 QUIT
- +3 ;
- IT NEW DA
- if $DATA(DA(1))
- SET PRCHDA1=DA(1)
- SET DA(1)=PRCHPO
- +1 SET BOC=$PIECE(PRCHS(I),U)
- SET AMT=$PIECE(PRCHS(I),U,2)
- SET DA=0
- IT1 ;LOOK FOR BOC
- +1 ;IF FOUND
- +2 ; 1, SEE IF FMS LINE NUMBER=991 & I FROM PRCHS(I)=991
- +3 ; A, IF SO, ENTER AMT AND QUIT
- +4 ; 2, SEE IF FMS LINE NUMBER'=991 & I '=991
- +5 ; A, IF SO, ENTER AMT AND QUIT
- +6 SET DA=$ORDER(^PRC(442,DA(1),22,"B",+BOC,DA))
- SET FLAGOK=""
- +7 IF DA>0
- Begin DoDot:1
- +8 SET UPDT=$GET(^PRC(442,DA(1),22,DA,0))
- SET LINO=$PIECE(UPDT,U,3)
- +9 IF LINO=991
- IF (I=991)
- SET $PIECE(UPDT,U,2)=AMT
- SET ^PRC(442,DA(1),22,DA,0)=UPDT
- SET FLAGOK=1
- QUIT
- +10 IF LINO'=991
- IF (I'=991)
- SET $PIECE(UPDT,U,2)=AMT
- SET ^PRC(442,DA(1),22,DA,0)=UPDT
- SET FLAGOK=1
- QUIT
- +11 QUIT
- End DoDot:1
- if FLAGOK=""
- GOTO IT1
- QUIT
- +12 ;IF YOU ARRIVED HERE & I=991 YOU NEED TO FIND THE IEN IN NODE 22
- +13 ;THAT HAS AN FMS LINE NUMBER = 991.
- +14 ;WHEN FOUND ENTER BOC & AMT FROM LINE IT+1 AND QUIT.
- +15 IF I=991
- Begin DoDot:1
- +16 SET DA=0
- FOR
- SET DA=$ORDER(^PRC(442,DA(1),22,DA))
- if DA'>0
- QUIT
- Begin DoDot:2
- +17 SET UPDT=$GET(^PRC(442,DA(1),22,DA,0))
- SET LINO=$PIECE(UPDT,U,3)
- +18 IF LINO=991
- SET $PIECE(UPDT,U)=BOC
- SET $PIECE(UPDT,U,2)=AMT
- SET ^PRC(442,DA(1),22,DA,0)=UPDT
- SET FLAGOK=1
- QUIT
- End DoDot:2
- if FLAGOK=1
- QUIT
- +19 QUIT
- End DoDot:1
- if FLAGOK=1
- QUIT
- +20 SET DIC="^PRC(442,"_DA(1)_",22,"
- SET DIC(0)="L"
- SET X=+BOC
- KILL DD,DO
- DO FILE^DICN
- IF Y'>0
- WRITE !," ERROR "
- QUIT
- +21 NEW DA
- SET DIE=DIC
- SET DA=+Y
- +22 SET LAST=LAST+1
- +23 SET DR="1////^S X=AMT;2////^S X=LAST"
- DO ^DIE
- KILL X,Y,DIE,DIC
- +24 if $DATA(PRCHDA1)
- SET DA(1)=PRCHDA1
- KILL PRCHDA1
- +25 QUIT
- +26 ;
- L if '$DATA(PRCHS("A",PRCHS("NS")))
- SET PRCHS("A",PRCHS("NS"))=""
- SET LICOST=+$PIECE(PRCHS("N2"),U,1)
- SET PRCHS("A",PRCHS("NS"))=+(PRCHS("A",PRCHS("NS")))+LICOST-$PIECE(PRCHS("N2"),U,6)
- +1 QUIT
- +2 ;
- LI2 SET CNT=CNT+1
- SET PRCHS(CNT)=J_U_PRCHS("A",J)
- KILL PRCHS("A",J)
- +1 QUIT
- +2 ;
- TM ;
- +1 SET PRCHS("T")=0
- SET I=0
- FOR
- SET I=$ORDER(^PRC(442,DA,5,I))
- if 'I
- QUIT
- SET X=^(I,0)
- IF +X>0
- SET I(100-X)=+X
- +2 if $ORDER(I(0))
- SET PRCHS("T")=I($ORDER(I(0)))
- SET PRCHS("T")=PRCHS("T")/100
- KILL I
- QUIT
- +3 QUIT