- 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 Mar 13, 2025@21:14:17 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")
