PRCFD8L ;WISC/LEM-FMS LIN,PVA,PVB,PVZ SEGMENTS ;7/24/97 14:07
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
LIN ;BUILD 'LIN' SEGMENT
S DA(421.541)=LINE,DR="1;2;3;14;41" D EN^DIQ1
S ^TMP($J,"PRCPV",LINE*4+1)="LIN^~"
Q
PVA ;BUILD 'PVA' SEGMENT
N SEG,ACCDATE,X1,X2,SERVDATE,CERTDATE
S (SEG,ACCDATE)=""
S (X2,SERVDATE)=PRCTMP(421.5,DA,11.5,"I")
S (X1,CERTDATE)=PRCTMP(421.5,DA,61.9,"I")
I X2,'X1 D
. S X1=X2,X2=7 D C^%DTC S ACCDATE=X Q
I SERVDATE,CERTDATE D
. S X1=CERTDATE,X2=SERVDATE D ^%DTC
. I X<8 S ACCDATE=CERTDATE Q
. I X>7 S X1=SERVDATE,X2=7 D C^%DTC S ACCDATE=X Q
S $P(SEG,U,1)="PVA" ; Segment ID
S X="000"_PRCTMP(421.541,DA(421.541),4,"E")
S $P(SEG,U,2)=$E(X,$L(X)-2,$L(X)) ; FMS Line Number
S $P(SEG,U,3)=PRCF("TC") ; Reference Document Transaction Code
S $P(SEG,U,4)=PRCF("TN") ; Transaction Number
S $P(SEG,U,5)=$P(SEG,U,2) ; Reference Document FMS Line Number
S $P(SEG,U,6)=$E(ACCDATE,2,3) ; Accept Year
S $P(SEG,U,7)=$E(ACCDATE,4,5) ; Accept Month
S $P(SEG,U,8)=$E(ACCDATE,6,7) ; Accept Day
S $P(SEG,U,21)=PRCTMP(421.541,DA(421.541),.01,"I") ; BOC
S X=PRCTMP(421.5,CI,2,"I")
S $P(SEG,U,29)=$E(X,2,3) ; Vendor's Invoice Year
S $P(SEG,U,30)=$E(X,4,5) ; Vendor's Invoice Month
S $P(SEG,U,31)=$E(X,6,7) ; Vendor's Invoice Day
S X=PRCTMP(421.541,DA(421.541),1,"I")
S $P(SEG,U,33)=$FN(X,"",2) ; Line Amount
S $P(SEG,U,34)="I" ;PRCTMP(421.541,DA(421.541),5,"I") ; Line Action (Increase/Decrease)
S $P(SEG,U,35)=PRCTMP(421.541,DA(421.541),3,"I") ; Partial/Final Indicator
S X=PRCTMP(421.5,CI,3,"I")
S $P(SEG,U,36)=$E(X,2,3) ; Year Invoice Logged
S $P(SEG,U,37)=$E(X,4,5) ; Month Invoice Logged
S $P(SEG,U,38)=$E(X,6,7) ; Day Invoice Logged
S X="" I PRCTMP(421.541,DA(421.541),4,"E")=991 S X="F"
S $P(SEG,U,39)=X ; Line Type
S $P(SEG,U,41)="~" ; Segment Delimiter
S ^TMP($J,"PRCPV",LINE*4+2)=SEG
Q
PVB ;BUILD 'PVB' SEGMENT
N SEG
S SEG="",$P(SEG,U,1)="PVB"
Q:+PRCTMP(421.541,DA(421.541),2,"I")=PRCTMP(421.541,DA(421.541),1,"I")
I PRCTMP(421.541,DA(421.541),2,"I")]"" D
. S $P(SEG,U,8)=$FN(PRCTMP(421.541,DA(421.541),2,"I"),"",2) ; Liquidation Amount
. S SEG=SEG_"^~",^TMP($J,"PRCPV",LINE*4+3)=SEG
Q
PVC ;BUILD 'PVC' SEGMENT
Q ; No data for now - Don't send PVC segment.
N SEG
S SEG="",$P(SEG,U,1)="PVC",$P(SEG,U,5)="~"
S ^TMP($J,"PRCPV",LINE*4+4)=SEG
Q
;
CVNFY(A,B) ;return conversion FY
N X,Y,Z S X="",Y=$O(^DIC(9.4,"B",A,"")) Q:Y="" X
S Z=0 F S Z=$O(^DIC(9.4,Y,22,Z)) Q:+Z'>0 I $E($G(^DIC(9.4,Y,22,Z,0)),1,$L(B))=B Q
Q:+Z'>0 X
S X=$P(^DIC(9.4,Y,22,Z,0),U,3)
S:X X=$E(X,1,3)+1700+$S(+$E(X,4,5)>9:1,1:0)
Q X
;
; USER OPTION TO SET UP SO to AR DATE
SOAR N DIR,X,X1,X2,PRCSOAR
SOAR0 S DIR(0)="D^DT:"_(DT+10000)_":EFX"
S DIR("B")=$$FMTE^XLFDT($G(^PRC(411,"A IFCAP-Wide Parameters","SO 2 AR Date"))) S:DIR("B")="" DIR("B")="10/12"
S DIR("A")=" "
S DIR("A",1)="Enter the date on which FMS will accrue their prior year documents."
S DIR("?")="The MM/DD/YY is provided by Central Office/FMS, normally via MailMan"
D ^DIR I Y="^" G SOARQ
I Y'>0 G SOAR0
W !
S PRCSOAR=Y
S X1=Y,X2=1 D C^%DTC
S DIR("A")="Is this correct?"
S DIR("A",1)="IFCAP will allow 'SO's to be sent to Austin as 'AR's starting on "_$$FMTE^XLFDT(X,2)_"."
S DIR(0)="Y"
S DIR("B")="NO"
S DIR("?")="Enter 'Y' to accept your entry, 'N' to change it"
D ^DIR I $D(DIRUT) G SOARQ
I Y S ^PRC(411,"A IFCAP-Wide Parameters","SO 2 AR Date")=PRCSOAR G SOARQ
I 'Y W !! G SOAR0
SOARQ Q
;
SOARINIT S ^PRC(411,"A IFCAP-Wide Parameters","SO 2 AR Date")=2961004 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFD8L 3634 printed Nov 22, 2024@17:12:50 Page 2
PRCFD8L ;WISC/LEM-FMS LIN,PVA,PVB,PVZ SEGMENTS ;7/24/97 14:07
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
LIN ;BUILD 'LIN' SEGMENT
+1 SET DA(421.541)=LINE
SET DR="1;2;3;14;41"
DO EN^DIQ1
+2 SET ^TMP($JOB,"PRCPV",LINE*4+1)="LIN^~"
+3 QUIT
PVA ;BUILD 'PVA' SEGMENT
+1 NEW SEG,ACCDATE,X1,X2,SERVDATE,CERTDATE
+2 SET (SEG,ACCDATE)=""
+3 SET (X2,SERVDATE)=PRCTMP(421.5,DA,11.5,"I")
+4 SET (X1,CERTDATE)=PRCTMP(421.5,DA,61.9,"I")
+5 IF X2
IF 'X1
Begin DoDot:1
+6 SET X1=X2
SET X2=7
DO C^%DTC
SET ACCDATE=X
QUIT
End DoDot:1
+7 IF SERVDATE
IF CERTDATE
Begin DoDot:1
+8 SET X1=CERTDATE
SET X2=SERVDATE
DO ^%DTC
+9 IF X<8
SET ACCDATE=CERTDATE
QUIT
+10 IF X>7
SET X1=SERVDATE
SET X2=7
DO C^%DTC
SET ACCDATE=X
QUIT
End DoDot:1
+11 ; Segment ID
SET $PIECE(SEG,U,1)="PVA"
+12 SET X="000"_PRCTMP(421.541,DA(421.541),4,"E")
+13 ; FMS Line Number
SET $PIECE(SEG,U,2)=$EXTRACT(X,$LENGTH(X)-2,$LENGTH(X))
+14 ; Reference Document Transaction Code
SET $PIECE(SEG,U,3)=PRCF("TC")
+15 ; Transaction Number
SET $PIECE(SEG,U,4)=PRCF("TN")
+16 ; Reference Document FMS Line Number
SET $PIECE(SEG,U,5)=$PIECE(SEG,U,2)
+17 ; Accept Year
SET $PIECE(SEG,U,6)=$EXTRACT(ACCDATE,2,3)
+18 ; Accept Month
SET $PIECE(SEG,U,7)=$EXTRACT(ACCDATE,4,5)
+19 ; Accept Day
SET $PIECE(SEG,U,8)=$EXTRACT(ACCDATE,6,7)
+20 ; BOC
SET $PIECE(SEG,U,21)=PRCTMP(421.541,DA(421.541),.01,"I")
+21 SET X=PRCTMP(421.5,CI,2,"I")
+22 ; Vendor's Invoice Year
SET $PIECE(SEG,U,29)=$EXTRACT(X,2,3)
+23 ; Vendor's Invoice Month
SET $PIECE(SEG,U,30)=$EXTRACT(X,4,5)
+24 ; Vendor's Invoice Day
SET $PIECE(SEG,U,31)=$EXTRACT(X,6,7)
+25 SET X=PRCTMP(421.541,DA(421.541),1,"I")
+26 ; Line Amount
SET $PIECE(SEG,U,33)=$FNUMBER(X,"",2)
+27 ;PRCTMP(421.541,DA(421.541),5,"I") ; Line Action (Increase/Decrease)
SET $PIECE(SEG,U,34)="I"
+28 ; Partial/Final Indicator
SET $PIECE(SEG,U,35)=PRCTMP(421.541,DA(421.541),3,"I")
+29 SET X=PRCTMP(421.5,CI,3,"I")
+30 ; Year Invoice Logged
SET $PIECE(SEG,U,36)=$EXTRACT(X,2,3)
+31 ; Month Invoice Logged
SET $PIECE(SEG,U,37)=$EXTRACT(X,4,5)
+32 ; Day Invoice Logged
SET $PIECE(SEG,U,38)=$EXTRACT(X,6,7)
+33 SET X=""
IF PRCTMP(421.541,DA(421.541),4,"E")=991
SET X="F"
+34 ; Line Type
SET $PIECE(SEG,U,39)=X
+35 ; Segment Delimiter
SET $PIECE(SEG,U,41)="~"
+36 SET ^TMP($JOB,"PRCPV",LINE*4+2)=SEG
+37 QUIT
PVB ;BUILD 'PVB' SEGMENT
+1 NEW SEG
+2 SET SEG=""
SET $PIECE(SEG,U,1)="PVB"
+3 if +PRCTMP(421.541,DA(421.541),2,"I")=PRCTMP(421.541,DA(421.541),1,"I")
QUIT
+4 IF PRCTMP(421.541,DA(421.541),2,"I")]""
Begin DoDot:1
+5 ; Liquidation Amount
SET $PIECE(SEG,U,8)=$FNUMBER(PRCTMP(421.541,DA(421.541),2,"I"),"",2)
+6 SET SEG=SEG_"^~"
SET ^TMP($JOB,"PRCPV",LINE*4+3)=SEG
End DoDot:1
+7 QUIT
PVC ;BUILD 'PVC' SEGMENT
+1 ; No data for now - Don't send PVC segment.
QUIT
+2 NEW SEG
+3 SET SEG=""
SET $PIECE(SEG,U,1)="PVC"
SET $PIECE(SEG,U,5)="~"
+4 SET ^TMP($JOB,"PRCPV",LINE*4+4)=SEG
+5 QUIT
+6 ;
CVNFY(A,B) ;return conversion FY
+1 NEW X,Y,Z
SET X=""
SET Y=$ORDER(^DIC(9.4,"B",A,""))
if Y=""
QUIT X
+2 SET Z=0
FOR
SET Z=$ORDER(^DIC(9.4,Y,22,Z))
if +Z'>0
QUIT
IF $EXTRACT($GET(^DIC(9.4,Y,22,Z,0)),1,$LENGTH(B))=B
QUIT
+3 if +Z'>0
QUIT X
+4 SET X=$PIECE(^DIC(9.4,Y,22,Z,0),U,3)
+5 if X
SET X=$EXTRACT(X,1,3)+1700+$SELECT(+$EXTRACT(X,4,5)>9:1,1:0)
+6 QUIT X
+7 ;
+8 ; USER OPTION TO SET UP SO to AR DATE
SOAR NEW DIR,X,X1,X2,PRCSOAR
SOAR0 SET DIR(0)="D^DT:"_(DT+10000)_":EFX"
+1 SET DIR("B")=$$FMTE^XLFDT($GET(^PRC(411,"A IFCAP-Wide Parameters","SO 2 AR Date")))
if DIR("B")=""
SET DIR("B")="10/12"
+2 SET DIR("A")=" "
+3 SET DIR("A",1)="Enter the date on which FMS will accrue their prior year documents."
+4 SET DIR("?")="The MM/DD/YY is provided by Central Office/FMS, normally via MailMan"
+5 DO ^DIR
IF Y="^"
GOTO SOARQ
+6 IF Y'>0
GOTO SOAR0
+7 WRITE !
+8 SET PRCSOAR=Y
+9 SET X1=Y
SET X2=1
DO C^%DTC
+10 SET DIR("A")="Is this correct?"
+11 SET DIR("A",1)="IFCAP will allow 'SO's to be sent to Austin as 'AR's starting on "_$$FMTE^XLFDT(X,2)_"."
+12 SET DIR(0)="Y"
+13 SET DIR("B")="NO"
+14 SET DIR("?")="Enter 'Y' to accept your entry, 'N' to change it"
+15 DO ^DIR
IF $DATA(DIRUT)
GOTO SOARQ
+16 IF Y
SET ^PRC(411,"A IFCAP-Wide Parameters","SO 2 AR Date")=PRCSOAR
GOTO SOARQ
+17 IF 'Y
WRITE !!
GOTO SOAR0
SOARQ QUIT
+1 ;
SOARINIT SET ^PRC(411,"A IFCAP-Wide Parameters","SO 2 AR Date")=2961004
QUIT
