PRCHPRCV ;WISC/DJM-FILE 442 CONVERSION ROUTINE ;8/30/95 1:41 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
LOOP N LOOP
S LOOP=0,COUNT=$P($G(^PRC(442,0)),U,4) I COUNT="" W:'$D(ZTQUEUED) !,"As you have nothing in file 442 for me to update I am going to quit." Q
I '$D(DT) D NOW^%DTC S DT=X
D NOW^%DTC S Y=% D DD^%DT W:'$D(ZTQUEUED) !!,"Starting conversion of file 442 on "_Y_".",!
S RECORD=$O(^PRC(411.3,"AD",0)) I RECORD>0 S LOOP=$O(^PRC(411.3,"AD",RECORD,0)) G:LOOP="DONE" END
I RECORD'>0 D
.S LOOKUP=$P($G(^PRC(411.3,0)),U,3) F S LOOKUP=LOOKUP+1 Q:$G(^PRC(411.3,LOOKUP,0))=""
.K DD,DO S X=LOOKUP,DLAYGO=411.3,DIC="^PRC(411.3,",DIC(0)="L" D FILE^DICN Q:+Y'>0 S $P(^PRC(411.3,+Y,0),U,11)=0,^PRC(411.3,"AD",+Y,0)=""
.S RECORD=+Y
D:'$D(ZTQUEUED) SETUP^PRCHRCV(COUNT)
S INIT=+$P($G(^PRC(411.3,RECORD,0)),U,12)
D:'$D(ZTQUEUED) UPDATE^PRCHRCV(INIT)
N AA,DA,DIC,DIE,DR,AMT1,AMT2,BOC1,BOC2,BOC31,LIN1,LIN2,N0,N1,N7,STAT,STAT1,F1,FY,CTR,EST,ESTA,ESTB,PRCA,SETBOC,SFCP,SFBOC,%,%H,X,ESTAA,LOOP1,LOOPB
S AA=0 F S LOOP=$O(^PRC(442,LOOP)) G:LOOP'>0 END D D UPDATE D:'$D(ZTQUEUED) UPDATE^PRCHRCV(0)
.S N0=$G(^PRC(442,LOOP,0)),N1=$G(^PRC(442,LOOP,1))
.S:$P(N0,U,6)=2699 $P(N0,U,6)=3131,AA=1
.S:$P(N0,U,8)=2699 $P(N0,U,8)=3131,AA=1
.I AA=1 S ^PRC(442,LOOP,0)=N0 D S AA=0
..S BOC31=$P($G(^PRCD(420.2,3131,0)),U),LOOP1=0
..F S LOOP1=$O(^PRC(442,LOOP,2,LOOP1)) Q:LOOP1'>0 S LOOPB=$G(^PRC(442,LOOP,2,LOOP1,0)) D
...I +$P(LOOPB,U,4)=2699 K DD,DO S DA(1)=LOOP,DIE="^PRC(442,"_DA(1)_",2,",DA=LOOP1,DR="3.5////^S X=BOC31" D ^DIE
.S FY=$P(N1,U,15) I FY]"" S ^PRC(442,"AB",FY,LOOP)=""
.I FY="" D DATE(LOOP,N0,.N1) S FY=$P(N1,U,15)
.S FY=$E(FY,2,3)+$E(FY,4)
.S P2237=$P(N0,U,12) I P2237>0 S RFY=$P($P($G(^PRCS(410,P2237,0)),U),"-",2) S:RFY]"" FY=RFY K RFY
.S FY=$$BBFY(+N0,FY,+$P(N0,U,3))
.S SFCP=$P(N0,U,19) I SFCP=1!(SFCP=2) S FY=1994
.S DIE="^PRC(442,",DA=LOOP,DR="26///^S X=FY" D ^DIE
.S N7=$G(^PRC(442,LOOP,7)),(STAT,STAT1)=$P(N7,U),STAT="/"_STAT_"/",F1=""
.I "/6/7/10/15/20/25/26/30/31/35/36/40/42/43/45/71/81/82/"[STAT D Q:F1=1
..S EST=$P(N0,U,13)
..I SFCP>0,EST>0 S SFBOC=$S(SFCP=1:2220,SFCP=2:2299,1:9999) D SETBOC(SFBOC)
..I SFCP=1!(SFCP=2) D EN^PRCUFC0(LOOP,SFCP,STAT1,N0,N1) S F1=1 Q
..I SFCP=3 D ROOLUP S F1=1 Q
..I SFCP'>0,EST>0 S AOBOC=2220 D SETBOC(AOBOC)
..K ^PRC(442,LOOP,22) S ^PRC(442,LOOP,22,0)="^"_$P(^DD(442,41,0),U,2)
..I $D(N0) D
...S BOC1=+$P(N0,U,6),AMT1=+$P(N0,U,7),BOC2=+$P(N0,U,8),AMT2=$P(N0,U,9)
...S (ESTAA,ESTA)=+$P(N0,U,13),LIN=991,ESTB=+$P($G(^PRC(442,LOOP,23)),U)
...S:BOC2>0 ESTA=ESTA/2,ESTA=ESTA*100+.5\1/100
...S AMT1=AMT1-ESTA
...S:BOC2>0 AMT2=AMT2-ESTA
...I BOC2=0 S LIN1=1 G ENTER
...I BOC1'>BOC2 S LIN1=1,LIN2=2
...I BOC2<BOC1 S LIN2=1,LIN1=2
ENTER ...S (DA(1),PRCDA)=DA
...K DD,DO S (DIC,PRCA)="^PRC(442,"_DA(1)_",22,",DIC(0)="L",X=BOC1 D FILE^DICN I Y>0 D
....S DIE=DIC,DA=+Y,DR="1////^S X=AMT1;2////^S X=LIN1" D ^DIE
...I BOC2>0 K DD,DO S DIC=PRCA,DIC(0)="L",X=BOC2 D FILE^DICN I Y>0 D
....S DIE=DIC,DA=+Y,DR="1////^S X=AMT2;2////^S X=LIN2" D ^DIE
...K DD,DO S DIC=PRCA,DIC(0)="L",X=ESTB D FILE^DICN I Y>0 D
....S DIE=DIC,DA=+Y,DR="1////^S X=ESTAA;2////^S X=LIN" D ^DIE
EXIT ;
D MM442^PRC5B
I '$D(ZTQUEUED) D NOW^%DTC S Y=% D DD^%DT W !!,"Ending conversion of file 442 on "_Y_".",!
Q
;
DATE(DA,N0,N1) ;
K OK D 1358(DA) Q:$D(OK)
D ASSIGNED(DA,.N1) Q
;
1358(DA) ;
N OB,OK,X,DATE K OK
;If obligation data, take date of first code sheet.
S OB=$O(^PRC(442,DA,10,0)) I +OB D Q:$D(OK)
.S X=$P($G(^PRC(442,DA,10,OB,0)),U,6) I $E(X,1,7)?7N D SET Q
.Q
Q
;
ASSIGNED(DA,N1) ;
S X=$P($G(^PRC(442,DA,12)),U,5),X=$P(X,".") I X?7N D SET Q:$D(OK)
S X=DT D SET
Q
;
SET ;
S DATE=$E(X,1,7)
S $P(N1,U,15)=DATE,DIE="^PRC(442,",DR=".1////^S X=DATE" D ^DIE
S OK=1 Q
;
SETBOC(BOC) ;
S BOC=$P($G(^PRCD(420.2,BOC,0)),U)
S DIE="^PRC(442,",DR="13.05////^S X=BOC" D ^DIE
Q
;
UPDATE ;
S DIE="^PRC(411.3,",DA=$O(^PRC(411.3,"AD",0)),DR="10///^S X=LOOP"
D ^DIE
Q
;
END ;
I LOOP'="DONE" S LOOP="DONE" D UPDATE
S $P(PRCSTAR,"*",80)="*"
W:'$D(ZTQUEUED) !,PRCSTAR
W:'$D(ZTQUEUED) !,"*** The PROCUREMENT & ACCOUNTING TRANSACTIONS file conversion is done. ***"
W:'$D(ZTQUEUED) !,PRCSTAR
G EXIT
;
ROOLUP ;
S $P(N0,U,5)=290000,^PRC(442,LOOP,0)=N0
S LOOP1=0,BOC=$P(^PRCD(420.2,9999,0),U)
F S LOOP1=$O(^PRC(442,LOOP,2,LOOP1)) Q:LOOP1'>0 D
.S $P(^PRC(442,LOOP,2,LOOP1,0),U,4)=BOC
.S ^PRC(442,LOOP,2,"D",+BOC,LOOP1)=""
.S ^PRC(442,LOOP,2,"AH",+BOC,$P(^PRC(442,LOOP,2,LOOP1,0),U),LOOP1)=""
.Q
N DA S (DA,PRCHPO)=LOOP
S DATE=$$DATE^PRC0C($P(N1,U,15),"I")
S PRC("FY")=$E($P(DATE,U),3,4)
S PRC("QTR")=$P(DATE,U,2)
S PRC("SITE")=+$P(N0,U)
S FCP=+$P(N0,U,3) I FCP]"" S PRC("CP")=+FCP
I '$D(PRC("PER")) D DUZ^PRCFSITE
D ^PRCHSF
Q
;
BBFY(A,B,C) ;
N D,E,F,X,Y
K PRC("BBFY")
S B=+$$YEAR^PRC0C(B)
S D=$$APP^PRC0C(A,$E(B,3,4),C)
S F=$$SFCP^PRC0D(A,C) I F=1!(F=2) S PRC("BBFY")=$S($P(D,"^",2)]"":$$FIRST^PRC0B1("^PRCD(420.14,""UNQ"","""_$P(D,"^",2)_""",",1993),1:"") QUIT PRC("BBFY")
I $P(D,"^")'["_/_" S PRC("BBFY")=B QUIT PRC("BBFY")
S F=$$BBFY^PRCHPRC1(A,C,1),Y=$P(F,"~",4)
S:Y?2.4N Y=+$$YEAR^PRC0C(Y) S PRC("BBFY")=$S(Y?4N:Y,1:"")
QUIT PRC("BBFY")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHPRCV 5317 printed Sep 23, 2025@19:45:34 Page 2
PRCHPRCV ;WISC/DJM-FILE 442 CONVERSION ROUTINE ;8/30/95 1:41 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
LOOP NEW LOOP
+1 SET LOOP=0
SET COUNT=$PIECE($GET(^PRC(442,0)),U,4)
IF COUNT=""
if '$DATA(ZTQUEUED)
WRITE !,"As you have nothing in file 442 for me to update I am going to quit."
QUIT
+2 IF '$DATA(DT)
DO NOW^%DTC
SET DT=X
+3 DO NOW^%DTC
SET Y=%
DO DD^%DT
if '$DATA(ZTQUEUED)
WRITE !!,"Starting conversion of file 442 on "_Y_".",!
+4 SET RECORD=$ORDER(^PRC(411.3,"AD",0))
IF RECORD>0
SET LOOP=$ORDER(^PRC(411.3,"AD",RECORD,0))
if LOOP="DONE"
GOTO END
+5 IF RECORD'>0
Begin DoDot:1
+6 SET LOOKUP=$PIECE($GET(^PRC(411.3,0)),U,3)
FOR
SET LOOKUP=LOOKUP+1
if $GET(^PRC(411.3,LOOKUP,0))=""
QUIT
+7 KILL DD,DO
SET X=LOOKUP
SET DLAYGO=411.3
SET DIC="^PRC(411.3,"
SET DIC(0)="L"
DO FILE^DICN
if +Y'>0
QUIT
SET $PIECE(^PRC(411.3,+Y,0),U,11)=0
SET ^PRC(411.3,"AD",+Y,0)=""
+8 SET RECORD=+Y
End DoDot:1
+9 if '$DATA(ZTQUEUED)
DO SETUP^PRCHRCV(COUNT)
+10 SET INIT=+$PIECE($GET(^PRC(411.3,RECORD,0)),U,12)
+11 if '$DATA(ZTQUEUED)
DO UPDATE^PRCHRCV(INIT)
+12 NEW AA,DA,DIC,DIE,DR,AMT1,AMT2,BOC1,BOC2,BOC31,LIN1,LIN2,N0,N1,N7,STAT,STAT1,F1,FY,CTR,EST,ESTA,ESTB,PRCA,SETBOC,SFCP,SFBOC,%,%H,X,ESTAA,LOOP1,LOOPB
+13 SET AA=0
FOR
SET LOOP=$ORDER(^PRC(442,LOOP))
if LOOP'>0
GOTO END
Begin DoDot:1
+14 SET N0=$GET(^PRC(442,LOOP,0))
SET N1=$GET(^PRC(442,LOOP,1))
+15 if $PIECE(N0,U,6)=2699
SET $PIECE(N0,U,6)=3131
SET AA=1
+16 if $PIECE(N0,U,8)=2699
SET $PIECE(N0,U,8)=3131
SET AA=1
+17 IF AA=1
SET ^PRC(442,LOOP,0)=N0
Begin DoDot:2
+18 SET BOC31=$PIECE($GET(^PRCD(420.2,3131,0)),U)
SET LOOP1=0
+19 FOR
SET LOOP1=$ORDER(^PRC(442,LOOP,2,LOOP1))
if LOOP1'>0
QUIT
SET LOOPB=$GET(^PRC(442,LOOP,2,LOOP1,0))
Begin DoDot:3
+20 IF +$PIECE(LOOPB,U,4)=2699
KILL DD,DO
SET DA(1)=LOOP
SET DIE="^PRC(442,"_DA(1)_",2,"
SET DA=LOOP1
SET DR="3.5////^S X=BOC31"
DO ^DIE
End DoDot:3
End DoDot:2
SET AA=0
+21 SET FY=$PIECE(N1,U,15)
IF FY]""
SET ^PRC(442,"AB",FY,LOOP)=""
+22 IF FY=""
DO DATE(LOOP,N0,.N1)
SET FY=$PIECE(N1,U,15)
+23 SET FY=$EXTRACT(FY,2,3)+$EXTRACT(FY,4)
+24 SET P2237=$PIECE(N0,U,12)
IF P2237>0
SET RFY=$PIECE($PIECE($GET(^PRCS(410,P2237,0)),U),"-",2)
if RFY]""
SET FY=RFY
KILL RFY
+25 SET FY=$$BBFY(+N0,FY,+$PIECE(N0,U,3))
+26 SET SFCP=$PIECE(N0,U,19)
IF SFCP=1!(SFCP=2)
SET FY=1994
+27 SET DIE="^PRC(442,"
SET DA=LOOP
SET DR="26///^S X=FY"
DO ^DIE
+28 SET N7=$GET(^PRC(442,LOOP,7))
SET (STAT,STAT1)=$PIECE(N7,U)
SET STAT="/"_STAT_"/"
SET F1=""
+29 IF "/6/7/10/15/20/25/26/30/31/35/36/40/42/43/45/71/81/82/"[STAT
Begin DoDot:2
+30 SET EST=$PIECE(N0,U,13)
+31 IF SFCP>0
IF EST>0
SET SFBOC=$SELECT(SFCP=1:2220,SFCP=2:2299,1:9999)
DO SETBOC(SFBOC)
+32 IF SFCP=1!(SFCP=2)
DO EN^PRCUFC0(LOOP,SFCP,STAT1,N0,N1)
SET F1=1
QUIT
+33 IF SFCP=3
DO ROOLUP
SET F1=1
QUIT
+34 IF SFCP'>0
IF EST>0
SET AOBOC=2220
DO SETBOC(AOBOC)
+35 KILL ^PRC(442,LOOP,22)
SET ^PRC(442,LOOP,22,0)="^"_$PIECE(^DD(442,41,0),U,2)
+36 IF $DATA(N0)
Begin DoDot:3
+37 SET BOC1=+$PIECE(N0,U,6)
SET AMT1=+$PIECE(N0,U,7)
SET BOC2=+$PIECE(N0,U,8)
SET AMT2=$PIECE(N0,U,9)
+38 SET (ESTAA,ESTA)=+$PIECE(N0,U,13)
SET LIN=991
SET ESTB=+$PIECE($GET(^PRC(442,LOOP,23)),U)
+39 if BOC2>0
SET ESTA=ESTA/2
SET ESTA=ESTA*100+.5\1/100
+40 SET AMT1=AMT1-ESTA
+41 if BOC2>0
SET AMT2=AMT2-ESTA
+42 IF BOC2=0
SET LIN1=1
GOTO ENTER
+43 IF BOC1'>BOC2
SET LIN1=1
SET LIN2=2
+44 IF BOC2<BOC1
SET LIN2=1
SET LIN1=2
ENTER SET (DA(1),PRCDA)=DA
+1 KILL DD,DO
SET (DIC,PRCA)="^PRC(442,"_DA(1)_",22,"
SET DIC(0)="L"
SET X=BOC1
DO FILE^DICN
IF Y>0
Begin DoDot:4
+2 SET DIE=DIC
SET DA=+Y
SET DR="1////^S X=AMT1;2////^S X=LIN1"
DO ^DIE
End DoDot:4
+3 IF BOC2>0
KILL DD,DO
SET DIC=PRCA
SET DIC(0)="L"
SET X=BOC2
DO FILE^DICN
IF Y>0
Begin DoDot:4
+4 SET DIE=DIC
SET DA=+Y
SET DR="1////^S X=AMT2;2////^S X=LIN2"
DO ^DIE
End DoDot:4
+5 KILL DD,DO
SET DIC=PRCA
SET DIC(0)="L"
SET X=ESTB
DO FILE^DICN
IF Y>0
Begin DoDot:4
+6 SET DIE=DIC
SET DA=+Y
SET DR="1////^S X=ESTAA;2////^S X=LIN"
DO ^DIE
End DoDot:4
End DoDot:3
End DoDot:2
if F1=1
QUIT
End DoDot:1
DO UPDATE
if '$DATA(ZTQUEUED)
DO UPDATE^PRCHRCV(0)
EXIT ;
+1 DO MM442^PRC5B
+2 IF '$DATA(ZTQUEUED)
DO NOW^%DTC
SET Y=%
DO DD^%DT
WRITE !!,"Ending conversion of file 442 on "_Y_".",!
+3 QUIT
+4 ;
DATE(DA,N0,N1) ;
+1 KILL OK
DO 1358(DA)
if $DATA(OK)
QUIT
+2 DO ASSIGNED(DA,.N1)
QUIT
+3 ;
1358(DA) ;
+1 NEW OB,OK,X,DATE
KILL OK
+2 ;If obligation data, take date of first code sheet.
+3 SET OB=$ORDER(^PRC(442,DA,10,0))
IF +OB
Begin DoDot:1
+4 SET X=$PIECE($GET(^PRC(442,DA,10,OB,0)),U,6)
IF $EXTRACT(X,1,7)?7N
DO SET
QUIT
+5 QUIT
End DoDot:1
if $DATA(OK)
QUIT
+6 QUIT
+7 ;
ASSIGNED(DA,N1) ;
+1 SET X=$PIECE($GET(^PRC(442,DA,12)),U,5)
SET X=$PIECE(X,".")
IF X?7N
DO SET
if $DATA(OK)
QUIT
+2 SET X=DT
DO SET
+3 QUIT
+4 ;
SET ;
+1 SET DATE=$EXTRACT(X,1,7)
+2 SET $PIECE(N1,U,15)=DATE
SET DIE="^PRC(442,"
SET DR=".1////^S X=DATE"
DO ^DIE
+3 SET OK=1
QUIT
+4 ;
SETBOC(BOC) ;
+1 SET BOC=$PIECE($GET(^PRCD(420.2,BOC,0)),U)
+2 SET DIE="^PRC(442,"
SET DR="13.05////^S X=BOC"
DO ^DIE
+3 QUIT
+4 ;
UPDATE ;
+1 SET DIE="^PRC(411.3,"
SET DA=$ORDER(^PRC(411.3,"AD",0))
SET DR="10///^S X=LOOP"
+2 DO ^DIE
+3 QUIT
+4 ;
END ;
+1 IF LOOP'="DONE"
SET LOOP="DONE"
DO UPDATE
+2 SET $PIECE(PRCSTAR,"*",80)="*"
+3 if '$DATA(ZTQUEUED)
WRITE !,PRCSTAR
+4 if '$DATA(ZTQUEUED)
WRITE !,"*** The PROCUREMENT & ACCOUNTING TRANSACTIONS file conversion is done. ***"
+5 if '$DATA(ZTQUEUED)
WRITE !,PRCSTAR
+6 GOTO EXIT
+7 ;
ROOLUP ;
+1 SET $PIECE(N0,U,5)=290000
SET ^PRC(442,LOOP,0)=N0
+2 SET LOOP1=0
SET BOC=$PIECE(^PRCD(420.2,9999,0),U)
+3 FOR
SET LOOP1=$ORDER(^PRC(442,LOOP,2,LOOP1))
if LOOP1'>0
QUIT
Begin DoDot:1
+4 SET $PIECE(^PRC(442,LOOP,2,LOOP1,0),U,4)=BOC
+5 SET ^PRC(442,LOOP,2,"D",+BOC,LOOP1)=""
+6 SET ^PRC(442,LOOP,2,"AH",+BOC,$PIECE(^PRC(442,LOOP,2,LOOP1,0),U),LOOP1)=""
+7 QUIT
End DoDot:1
+8 NEW DA
SET (DA,PRCHPO)=LOOP
+9 SET DATE=$$DATE^PRC0C($PIECE(N1,U,15),"I")
+10 SET PRC("FY")=$EXTRACT($PIECE(DATE,U),3,4)
+11 SET PRC("QTR")=$PIECE(DATE,U,2)
+12 SET PRC("SITE")=+$PIECE(N0,U)
+13 SET FCP=+$PIECE(N0,U,3)
IF FCP]""
SET PRC("CP")=+FCP
+14 IF '$DATA(PRC("PER"))
DO DUZ^PRCFSITE
+15 DO ^PRCHSF
+16 QUIT
+17 ;
BBFY(A,B,C) ;
+1 NEW D,E,F,X,Y
+2 KILL PRC("BBFY")
+3 SET B=+$$YEAR^PRC0C(B)
+4 SET D=$$APP^PRC0C(A,$EXTRACT(B,3,4),C)
+5 SET F=$$SFCP^PRC0D(A,C)
IF F=1!(F=2)
SET PRC("BBFY")=$SELECT($PIECE(D,"^",2)]"":$$FIRST^PRC0B1("^PRCD(420.14,""UNQ"","""_$PIECE(D,"^",2)_""",",1993),1:"")
QUIT PRC("BBFY")
+6 IF $PIECE(D,"^")'["_/_"
SET PRC("BBFY")=B
QUIT PRC("BBFY")
+7 SET F=$$BBFY^PRCHPRC1(A,C,1)
SET Y=$PIECE(F,"~",4)
+8 if Y?2.4N
SET Y=+$$YEAR^PRC0C(Y)
SET PRC("BBFY")=$SELECT(Y?4N:Y,1:"")
+9 QUIT PRC("BBFY")
