- 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 Jan 18, 2025@03:05:22 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