- 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 Mar 13, 2025@21:07:31 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
