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