PRCFOOR2 ;WISC@ALTOONA/CTB-UPDATE FCP BALANCES ;9/29/94 8:41 AM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;PROGRAM TO UPDATE BALANCES FROM AUSTIN
;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 HEADER
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'["CCP" D ERRMSG(2) QUIT
; 3 is site correct
S SITE=$P(NODE,"^",4) I SITE="" D ERRMSG(3) QUIT
I '$D(^PRC(420,SITE)) D ERRMSG(3) QUIT
;MOVE MESSAGE INTO 420.97
S LINE=10000 F S LINE=$O(^PRCF(423.6,XDA,1,LINE)) Q:'LINE I $D(^(LINE,0)),$E(^(0))'="{" D FILE(XDA,LINE)
;VALIDATE DATA, PROCESS UPDATE ADJUSTMENTS
S DA=0 F S DA=$O(^PRCU(420.97,DA)) Q:'DA D UPDATE(DA)
S NEXT="" F S NEXT=$O(^PRCU(420.99,"AB",NEXT)) Q:NEXT="" I '$D(^PRCU(420.97,"B",NEXT)) D ADDERR(3,$P(NEXT,"-"),$P(NEXT,"-",2))
D FCPBULL^PRCFOOR4(PRCDA)
QUIT
REPORT ;GENERATE REPORTS OF CCP MESSAGES
S DIC="^PRCU(420.99,",L=0,(BY,FLDS)="[PRCF FMS ADJUSTMENTS]" D EN1^DIP
S DIC="^PRCU(420.98,",L=0,(BY,FLDS)="[PRCF FMS ADJUSTMENTS]" D EN1^DIP
QUIT
ERRMSG(X) S X=$P($T(MSG+X),";",3,99) D MSG^PRCFQ W ! QUIT
MSG ;
;;Invalid Message Destination
;;Invalid Message Type/Segment
;;Station Number is Missing from Message
;;Message Contains No Data Lines
;;Unable to extract Fund Control Point from Data line
FILE(XDA,LINE) ; check each transmission line sent and file in 420.97
NEW BBFY,FUND,AO,ACC,NODE,BALANCE,OUT,FCP,VIFCAPCP,VSNAPCP,SNAPDA,SNAPSHOT,VARIANCE
S NODE=$G(^PRCF(423.6,XDA,1,LINE,0))
I $E(NODE)="{" S DONE="" QUIT
S BALANCE=$P(NODE,"^",12)
; 4 was data sent in the transmission
I '$D(^PRCF(423.6,XDA,1,LINE,0)) D ERRMSG(4) Q
S SITE=$P(NODE,"^",6),FCP=$P(NODE,"^",11)
IF SITE=""!(FCP="") QUIT ;
S BBFY=$P(NODE,"^",2),FUND=$P(NODE,"^",4),AO=$P(NODE,"^",5),ACC=$P(NODE,"^",8)
S STRIP=SITE_","_BBFY_","_FUND_","_AO_","_ACC
D ADD(SITE,FCP,BALANCE,STRIP)
QUIT
ADD(SITE,FCP,BAL,STRIP) ;
NEW DIC,DIE,X,Y,DA,DR,DLAYGO
S (DIC,DLAYGO)=420.97,DIC(0)="LNX",X=SITE_"-"_+FCP D ^DIC
S DA=+Y,DIE=DIC
S DR="1///"_SITE_";2///"_STRIP_";3////"_BAL S:FCP]"" DR=DR_";2.5///"_FCP
D ^DIE
QUIT
UPDATE(DA) ;
NEW RECORD,SITE,FCP,BAL
S RECORD=^PRCU(420.97,DA,0)
S SITE=$P(RECORD,"^",2),FCP=$P(RECORD,"^",5),BAL=$P(RECORD,"^",4)
S VIFCAPCP=$$VALIDCP(SITE,FCP)
S VSNAPCP=0 I $D(^PRCU(420.99,"AB",SITE_"-"_+FCP)) S VSNAPCP=1
S SNAPDA=$O(^PRCU(420.99,"AB",SITE_"-"_+FCP,0))
I 'VIFCAPCP D ADDERR(1,SITE,FCP) QUIT ;FMS CP NOT IN IFCAP
I 'VSNAPCP D ADDERR(2,SITE,FCP) QUIT ;FMS CP NOT IN SNAPSHOT FILE
S SNAPSHOT=$P(^PRCU(420.99,SNAPDA,0),"^",3),ID=$P(^(0),"^"),DONE=$P(^(0),"^",10)
I DONE D ADDERR(4,SITE,FCP) QUIT ;ALREADY ADJUSTED
S VARIANCE=SNAPSHOT-BAL
D CONV^PRCSREC2(ID,VARIANCE,"FMS FCP CONVERSION ADJUSTMENT")
S $P(^PRCU(420.99,SNAPDA,0),"^",8,10)=BAL_"^"_VARIANCE_"^1"
QUIT
ADDERR(A,B,C) NEW DIC,DIE,X,Y,DA,DR,DLAYGO
S (DIC,DLAYGO)=420.98,DIC(0)="LN",X="+" D ^DIC
S DIE=DIC,DR="1////"_B_";2////"_A_";3////"_C,DA=+Y D ^DIE
QUIT
VALIDCP(SITE,CP) ;VALIDATE FUND CONTROL POINT NUMBER
I $D(^PRC(420,+SITE,1,+CP,0)) Q 1
Q 0
NEXT ;
I $E(X)'="+" Q
N A
S A="S X=$P("_DIC_"0),U,3)" X A S A="S X=X+1 L +"_DIC_"0)" F X A Q:'$D(@(DIC_X_")")) L @("-"_DIC_"0)")
I X=+X S DINUM=X QUIT
S X="" QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFOOR2 3741 printed Nov 22, 2024@17:14:16 Page 2
PRCFOOR2 ;WISC@ALTOONA/CTB-UPDATE FCP BALANCES ;9/29/94 8:41 AM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;PROGRAM TO UPDATE BALANCES FROM AUSTIN
+3 ;READ MESSAGE INTO FILE 420.97
+4 ;PROCESS EXISTING CONTROL POINTS USING 420.99 AS SOURCE
+5 ;BUILDING LIST OF EXCEPTIONS ON THE FLY ^TMP("NOT IN AUSTIN",SITE,CP)
+6 ;BUILD LIST OF CP FROM AUSTIN NOT FOUND IN 420.99 ^TMP("NOT IN IFCAP,SITE,CP)
+7 ;PRINT EXCEPTION LISTS
+8 ;
+9 ;READ MESSAGE HEADER
+10 if '$DATA(PRCDA)
QUIT
+11 SET OUT=0
SET (FCP,SITE)=""
+12 DO NOW^%DTC
SET RDATE=%
SET XDA=PRCDA
+13 SET NODE=$GET(^PRCF(423.6,XDA,1,10000,0))
IF NODE=""
DO ERRMSG(4)
QUIT
+14 ; 1,2 is this the right type of transaction
+15 SET CHECK=$PIECE(NODE,"^",3)
IF CHECK'["IFC"
DO ERRMSG(1)
QUIT
+16 SET CHECK=$PIECE(NODE,"^",5)
IF CHECK'["CCP"
DO ERRMSG(2)
QUIT
+17 ; 3 is site correct
+18 SET SITE=$PIECE(NODE,"^",4)
IF SITE=""
DO ERRMSG(3)
QUIT
+19 IF '$DATA(^PRC(420,SITE))
DO ERRMSG(3)
QUIT
+20 ;MOVE MESSAGE INTO 420.97
+21 SET LINE=10000
FOR
SET LINE=$ORDER(^PRCF(423.6,XDA,1,LINE))
if 'LINE
QUIT
IF $DATA(^(LINE,0))
IF $EXTRACT(^(0))'="{"
DO FILE(XDA,LINE)
+22 ;VALIDATE DATA, PROCESS UPDATE ADJUSTMENTS
+23 SET DA=0
FOR
SET DA=$ORDER(^PRCU(420.97,DA))
if 'DA
QUIT
DO UPDATE(DA)
+24 SET NEXT=""
FOR
SET NEXT=$ORDER(^PRCU(420.99,"AB",NEXT))
if NEXT=""
QUIT
IF '$DATA(^PRCU(420.97,"B",NEXT))
DO ADDERR(3,$PIECE(NEXT,"-"),$PIECE(NEXT,"-",2))
+25 DO FCPBULL^PRCFOOR4(PRCDA)
+26 QUIT
REPORT ;GENERATE REPORTS OF CCP MESSAGES
+1 SET DIC="^PRCU(420.99,"
SET L=0
SET (BY,FLDS)="[PRCF FMS ADJUSTMENTS]"
DO EN1^DIP
+2 SET DIC="^PRCU(420.98,"
SET L=0
SET (BY,FLDS)="[PRCF FMS ADJUSTMENTS]"
DO EN1^DIP
+3 QUIT
ERRMSG(X) SET X=$PIECE($TEXT(MSG+X),";",3,99)
DO MSG^PRCFQ
WRITE !
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 ;;Unable to extract Fund Control Point from Data line
FILE(XDA,LINE) ; check each transmission line sent and file in 420.97
+1 NEW BBFY,FUND,AO,ACC,NODE,BALANCE,OUT,FCP,VIFCAPCP,VSNAPCP,SNAPDA,SNAPSHOT,VARIANCE
+2 SET NODE=$GET(^PRCF(423.6,XDA,1,LINE,0))
+3 IF $EXTRACT(NODE)="{"
SET DONE=""
QUIT
+4 SET BALANCE=$PIECE(NODE,"^",12)
+5 ; 4 was data sent in the transmission
+6 IF '$DATA(^PRCF(423.6,XDA,1,LINE,0))
DO ERRMSG(4)
QUIT
+7 SET SITE=$PIECE(NODE,"^",6)
SET FCP=$PIECE(NODE,"^",11)
+8 ;
IF SITE=""!(FCP="")
QUIT
+9 SET BBFY=$PIECE(NODE,"^",2)
SET FUND=$PIECE(NODE,"^",4)
SET AO=$PIECE(NODE,"^",5)
SET ACC=$PIECE(NODE,"^",8)
+10 SET STRIP=SITE_","_BBFY_","_FUND_","_AO_","_ACC
+11 DO ADD(SITE,FCP,BALANCE,STRIP)
+12 QUIT
ADD(SITE,FCP,BAL,STRIP) ;
+1 NEW DIC,DIE,X,Y,DA,DR,DLAYGO
+2 SET (DIC,DLAYGO)=420.97
SET DIC(0)="LNX"
SET X=SITE_"-"_+FCP
DO ^DIC
+3 SET DA=+Y
SET DIE=DIC
+4 SET DR="1///"_SITE_";2///"_STRIP_";3////"_BAL
if FCP]""
SET DR=DR_";2.5///"_FCP
+5 DO ^DIE
+6 QUIT
UPDATE(DA) ;
+1 NEW RECORD,SITE,FCP,BAL
+2 SET RECORD=^PRCU(420.97,DA,0)
+3 SET SITE=$PIECE(RECORD,"^",2)
SET FCP=$PIECE(RECORD,"^",5)
SET BAL=$PIECE(RECORD,"^",4)
+4 SET VIFCAPCP=$$VALIDCP(SITE,FCP)
+5 SET VSNAPCP=0
IF $DATA(^PRCU(420.99,"AB",SITE_"-"_+FCP))
SET VSNAPCP=1
+6 SET SNAPDA=$ORDER(^PRCU(420.99,"AB",SITE_"-"_+FCP,0))
+7 ;FMS CP NOT IN IFCAP
IF 'VIFCAPCP
DO ADDERR(1,SITE,FCP)
QUIT
+8 ;FMS CP NOT IN SNAPSHOT FILE
IF 'VSNAPCP
DO ADDERR(2,SITE,FCP)
QUIT
+9 SET SNAPSHOT=$PIECE(^PRCU(420.99,SNAPDA,0),"^",3)
SET ID=$PIECE(^(0),"^")
SET DONE=$PIECE(^(0),"^",10)
+10 ;ALREADY ADJUSTED
IF DONE
DO ADDERR(4,SITE,FCP)
QUIT
+11 SET VARIANCE=SNAPSHOT-BAL
+12 DO CONV^PRCSREC2(ID,VARIANCE,"FMS FCP CONVERSION ADJUSTMENT")
+13 SET $PIECE(^PRCU(420.99,SNAPDA,0),"^",8,10)=BAL_"^"_VARIANCE_"^1"
+14 QUIT
ADDERR(A,B,C) NEW DIC,DIE,X,Y,DA,DR,DLAYGO
+1 SET (DIC,DLAYGO)=420.98
SET DIC(0)="LN"
SET X="+"
DO ^DIC
+2 SET DIE=DIC
SET DR="1////"_B_";2////"_A_";3////"_C
SET DA=+Y
DO ^DIE
+3 QUIT
VALIDCP(SITE,CP) ;VALIDATE FUND CONTROL POINT NUMBER
+1 IF $DATA(^PRC(420,+SITE,1,+CP,0))
QUIT 1
+2 QUIT 0
NEXT ;
+1 IF $EXTRACT(X)'="+"
QUIT
+2 NEW A
+3 SET A="S X=$P("_DIC_"0),U,3)"
XECUTE A
SET A="S X=X+1 L +"_DIC_"0)"
FOR
XECUTE A
if '$DATA(@(DIC_X_")"))
QUIT
LOCK @("-"_DIC_"0)")
+4 IF X=+X
SET DINUM=X
QUIT
+5 SET X=""
QUIT
