source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFOOR3.m@ 1746

PRCFOOR3 ;WISC@ALTOONA/CTB-OUTSTANDING OBLIGATION RECONCILIATION ;12/15/94  3:59 PM
V ;;5.1;IFCAP;;Oct 20, 2000
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;READ MESSAGE INTO FILE 420.97
 ;PROCESS EXISTING CONTROL POINTS USING 420.99 AS SOURCE
 ;BUILDING LIST OF EXCEPTIONS ON THE FLY ^TMP("NOT IN AUSTIN",SITE,CP)
 ;BUILD LIST OF CP FROM AUSTIN NOT FOUND IN 420.99 ^TMP("NOT IN IFCAP,SITE,CP)
 ;PRINT EXCEPTION LISTS
 ;
 ;READ MESSAGE
X Q:'$D(PRCDA)
 S OUT=0,(FCP,SITE)=""
 D NOW^%DTC S RDATE=%,XDA=PRCDA
 S NODE=$G(^PRCF(423.6,XDA,1,10000,0)) I NODE="" D ERRMSG(4) QUIT
 ; 1,2 is this the right type of transaction
 S CHECK=$P(NODE,"^",3) I CHECK'["IFC" D ERRMSG(1) QUIT
 S CHECK=$P(NODE,"^",5) I CHECK'["OOR" D ERRMSG(2) QUIT
 ; 3 is site correct
 S SITE=$P(NODE,"^",4) I SITE="" D ERRMSG(3) QUIT
CLEAN ;CLEAN ALL RECORDS FROM 420.96 FOR STATION
 D CLEAN^PRCFOOR4(SITE)
 ;MOVE MESSAGE INTO 420.96
 S LINE=10000 F  S LINE=$O(^PRCF(423.6,XDA,1,LINE)) Q:'LINE  D FILE(XDA,.LINE)
 ;GET OUT OF RANGE FY
 D FY
IFCAP ;LOOP THROUGH PO FILE FOR OPEN IFCAP RECORDS
 FOR FSO=25,26,30,31,35,36,42,43,100 S PODA=0 F  S PODA=$O(^PRC(442,"AI",FSO,PODA)) Q:'PODA  I $$CHECK(PODA,FSO) D ADD1(PODA)
 ;SEND BULLETIN TO MAIL GROUP
 D BULL^PRCFOOR4(PRCDA)
 ;REMOVE MESSAGE
 ;D REMOVE^PRCFOOR4(PRCDA)
 QUIT
ADD1(PODA) ;ADD RECORD TO 420.96 WITH STATUS OF 1
 N DLAYGO,IFBAL
 S IFBAL=$$GETBAL(PODA)
 Q:+IFBAL=0
 S (DIC,DLAYGO)=420.96,DIC(0)="MNL",X=$P($G(^PRC(442,PODA,0)),"^") Q:X=""
 D ^DIC Q:Y<0
 S DIE=DIC,DA=+Y,DR="3////"_PODA_";4////"_IFBAL_";5////1"
 D ^DIE
 QUIT
CHECK(PODA,FSO) ;QUIT WHEN CLOSED, NOT YET COMPLETE, OR NO MATCH ON SITE
 ;FSO=FISCAL STATUS ORDER
 NEW XFSO,OPEN,MOP,ID
 I +$G(^PRC(442,PODA,0))'=SITE QUIT 0
 I $P($G(^PRC(442,PODA,1)),"^",15)<SELFY QUIT 0
 S XFSO=$P($G(^PRC(442,PODA,7)),"^",4)
 I XFSO'=FSO QUIT 0
 ;CHECK MOP QUIT WHEN MOP=9 OR MOP=24 (ISSUES OR AR)
 S MOP=$P($G(^PRC(442,PODA,0)),"^",2)
 I (MOP="")!(MOP=9)!(MOP=24) QUIT 0
 ;I MOP=A1358 QUIT WHEN BALANCE IS ZERO
 I MOP=21,$P($$BAL^PRCH58(PODA),"^",2)=0 QUIT 0
 ;CHECK TO SEE IF DOCUMENT IS ALREADY IN 420.96
 S ID=$P($G(^PRC(442,PODA,0)),"^") I ID="" QUIT 0
 I $D(^PRCU(420.96,"B",ID)) QUIT 0
 QUIT 1
ERRMSG(X) ;
 S X=$P($T(MSG+X),";",3,99) D BULL1^PRCFOOR4(PRCDA,X) QUIT
MSG ;
 ;;Invalid Message Destination
 ;;Invalid Message Type/Segment
 ;;Station Number is Missing from Message
 ;;Message Contains No Data Lines
 ;;
FILE(XDA,LINE) ;  check each transmission line sent and file in 420.6
 NEW SITE,NODE,FMSBAL,OUT,FCP,VIFCAPCP,SITE,VSNAPCP,SNAPDA,SNAPSHOT,VARIANCE
 S NODE=$G(^PRCF(423.6,XDA,1,LINE,0))
 Q:NODE=""!($P(NODE,"^")'="OOR")
 S SITE=$P(NODE,"^",10)
 S FMSBAL=+$P(NODE,"^",5)
 S FMSFCP=$P(NODE,"^",12)
 S FMSLINE=$P(NODE,"^",4)
 S FMSPAT=$E($P(NODE,"^",3),4,99)
 ;CHECK NEXT LINE - IF IT IS SAME PO, ACCUMULATE FMS BAL
 F  D  I $D(OUT) K OUT Q
 . N NEXTNODE,NSITE,NPAT
 . S NEXTNODE=$G(^PRCF(423.6,XDA,1,LINE+1,0))
 . I NEXTNODE=""!($P(NEXTNODE,"^")["{") S OUT="" Q
 . S NPAT=$E($P(NEXTNODE,"^",3),4,99)
 . I NPAT=FMSPAT S FMSBAL=FMSBAL+$P(NEXTNODE,"^",5),LINE=LINE+1 K OUT QUIT
 . S OUT=1 QUIT
 ;S IFCP=KARENS CALL
 S ID=+SITE_"-"_FMSPAT
 S IFPODA=$$GET(ID)
 S IFBAL=$$GETBAL(+IFPODA)
 D ADD(ID,FMSFCP,FMSBAL,IFPODA,IFBAL,FMSLINE)
 QUIT
GET(X) ;GET IFCAP PO NUMBER
 N DIC,Y
 S DIC=442,DIC(0)="MN" D ^DIC
 Q $S(Y>0:Y,1:"")
GETBAL(X) ;
 NEW NODE,OBLIG,RECVD
 I X="" QUIT ""
 S NODE=$G(^PRC(442,X,0))
 I NODE="" QUIT ""
 ;GET ORIGINAL OBLIGATION AMOUNT
 S OBLIG=$P(NODE,"^",16)
 ;GET VALUE OF ALL RECEIVING REPORTS
 S RECVD=$P(NODE,"^",17)
 Q (OBLIG-RECVD)
ADD(ID,FMSFCP,FMSBAL,IFPODA,IFBAL,FMSLINE) ;
 ;NEW FSO,DIC,DIE,X,Y,DA,DR,DLAYGO,UDOBAL
 ;FSO=FISCAL STATUS ORDER
 S FSO=$S(IFPODA="":"",1:$P($G(^PRC(442,IFPODA,7)),"^",4))
 ;SET FSO=4 IF NO PO, 2 IF COMPLETE, 3 IF OPEN, 0 IF VALID
 S IFSTATUS=$S('IFPODA:4,FSO=40:2,FSO=41:2,(FMSBAL'=IFBAL):3,1:0)
 IF IFSTATUS=0 QUIT
 N DLAYGO S (DIC,DLAYGO)=420.96,DIC(0)="LN",X=ID D ^DIC
 S DA=+Y
 S DIE=DIC,DR="1////"_+FMSBAL_";2////"_FMSFCP_";2.5////"_FMSLINE_";3////"_+IFPODA_";4////"_IFBAL_";5////"_IFSTATUS
 D ^DIE
 QUIT
VALIDCP(SITE,CP) ;VALIDATE FUND CONTROL POINT NUMBER
 I $D(^PRC(420,+SITE,1,+CP,0)) Q 1
 Q 0
FY N CFY,X
 D NOW^%DTC
 S CFY=$E(X,1,3),CFY=$S(+$E(X,4,5)<10:CFY-1,1:CFY)
 S SELFY=(CFY-1)_1000