- PRCAKBT1 ;WASH-ISC@ALTOONA,PA/CMS-AR BUILD TEMP ARCHIVE FILE CONT. ;7/3/96 11:17 AM
- V ;;4.5;Accounts Receivable;**46**;Mar 20, 1995
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- NEW DA,DIC,DIQ,DR,FIL,II,PRCABN
- F PRCABN=0:0 S PRCABN=$O(^PRCA(430,"AC",STAT,PRCABN)) Q:'PRCABN D SET
- Q
- SET ;create data records
- N BN0,DA,PRCATN,TN
- S BN0=$G(^PRCA(430,PRCABN,0)) I BN0="" K ^PRCA(430,"AC",STAT,PRCABN) Q
- I $P(BN0,"^")="" S ^TMP("PRCAK",$J,"E",^TMP("PRCAK",$J,"E"))="Bill number not defined for entry #"_PRCABN_" in file 430!",^TMP("PRCAK",$J,"E")=^TMP("PRCAK",$J,"E")+1 Q
- I '$D(^PRCA(430,"B",$P(BN0,U,1),PRCABN)) S ^PRCA(430,"B",$P(BN0,U,1),PRCABN)=""
- D P430 I '$D(^UTILITY("DIQ1",$J)) S ^TMP("PRCAK",$J,"E",^TMP("PRCAK",$J,"E"))="Could not set Archive data record for Bill NO. "_$P(BN0,U),^TMP("PRCAK",$J,"E")=^TMP("PRCAK",$J,"E")+1 Q
- F PRCATN=0:0 S PRCATN=$O(^PRCA(433,"C",PRCABN,PRCATN)) Q:'PRCATN I $G(^PRCA(433,PRCATN,0))'="" D P433
- K ^UTILITY("DIQ1",$J)
- Q
- P430 ;get all 430 data
- N DA,DIC,DIQ,DR,II,SF,SN,TN
- K ^UTILITY("DIQ1",$J)
- F II=2,5,10,101 I $D(^PRCA(430,PRCABN,II,0)) D
- .F SN=0:0 S SN=$O(^PRCA(430,PRCABN,II,SN)) Q:'SN S SF(II,SN)=""
- S DA=PRCABN,DIC="^PRCA(430,",DIQ(0)="EN",DR=".001:99999999" D EN^DIQ1
- S DR(430.01)=DR,DR(430.02)=DR,DR(430.051)=DR,DR(430.098)=DR
- F II=0:0 S II=$O(SF(II)) Q:'II F SN=0:0 S SN=$O(SF(II,SN)) Q:'SN S DA($S(II=2:430.01,II=5:430.051,II=10:430.098,1:430.02))=SN S DIQ(0)="EN" D EN^DIQ1
- I $D(^UTILITY("DIQ1",$J)) S TN=0 D ENT
- Q
- P433 ;Get all 433 data
- N DA,DIC,DIQ,DR,II,SF,SN
- K ^UTILITY("DIQ1",$J)
- F II=4,6,7 I $D(^PRCA(433,PRCATN,II,0)) D
- .F SN=0:0 S SN=$O(^PRCA(433,PRCATN,II,SN)) Q:'SN S SF(II,SN)=""
- S DA=PRCATN,DIC="^PRCA(433,",DIQ(0)="EN",DR=".001:99999999" D EN^DIQ1
- S DR(433.01)=DR,DR(433.04)=DR,DR(433.061)=DR
- F II=0:0 S II=$O(SF(II)) Q:'II F SN=0:0 S SN=$O(SF(II,SN)) Q:'SN S DA($S(II=4:433.01,II=6:433.061,1:433.04))=SN S DIQ(0)="EN" D EN^DIQ1
- I '$D(^UTILITY("DIQ1",$J)) S ^TMP("PRCAK",$J,"E",^TMP("PRCAK",$J,"E"))="Could not create Archive data record for Tran. No. "_PRCABN_" of Bill # "_$P(BN0,"^"),^TMP("PRCAK",$J,"E")=^TMP("PRCAK",$J,"E")+1 Q
- S TN=$G(TN)+1 D ENT
- Q
- ENT ;Enter Data records in File 430.8
- N DAT,DD,DIC,DINUM,DLAYGO,DO,FIL,FLD,I,IFN,X,Y,LN
- S DLAYGO=430.8,DIC="^PRCAK(430.8,",DIC(0)="L"
- S DIC("W")="",X=$P(BN0,"^",1)_"-"_TN D ^DIC
- I Y<0 S ^TMP("PRCAK",$J,"E",^TMP("PRCAK",$J,"E"))="Could not archive entry "_X_" (IEN: "_PRCABN_") due to invalid identifier.",^TMP("PRCAK",$J,"E")=^TMP("PRCAK",$J,"E")+1 Q
- I '$P(Y,"^",3) S ^TMP("PRCAK",$J,"E",^TMP("PRCAK",$J,"E"))="Could not archive entry "_X_" (IEN: "_PRCABN_") due to duplicate entry.",^TMP("PRCAK",$J,"E")=^TMP("PRCAK",$J,"E")+1 Q
- S CNT=$G(CNT)+1,$P(^PRCAK(430.8,+Y,0),"^",2)=$$NAM^RCFN01($P(BN0,"^",9))
- S $P(^PRCAK(430.8,+Y,0),"^",3)=$$SSN^RCFN01($P(BN0,"^",9)),$P(^(0),"^",4)=0
- S ^PRCAK(430.8,+Y,1,0)="^^0^0^"_DT_"^"
- S FIL="" F S FIL=$O(^UTILITY("DIQ1",$J,FIL)) Q:FIL="" F IFN=0:0 S IFN=$O(^UTILITY("DIQ1",$J,FIL,IFN)) Q:'IFN D
- .S FLD="" F S FLD=$O(^UTILITY("DIQ1",$J,FIL,IFN,FLD)) Q:FLD="" S I=$O(^(FLD,"")) D
- ..I I="E" S DAT=$G(^TMP("PRCAK",$J,"F",FIL,FLD))_":"_^UTILITY("DIQ1",$J,FIL,IFN,FLD,"E") D ADD I FIL=433,FLD=.01 S $P(^PRCAK(430.8,+Y,0),U,4)=$P(DAT,":",2) Q
- ..S I=0 F S I=$O(^UTILITY("DIQ1",$J,FIL,IFN,FLD,I)) Q:'I S DAT=$G(^TMP("PRCAK",$J,"F",FIL,FLD))_":"_^UTILITY("DIQ1",$J,FIL,IFN,FLD,I) D ADD
- .S DAT="" D SAVE
- Q
- ADD ;add to WP field
- I $G(LN)="" S LN=" "_DAT Q
- I ($L(DAT)+$L(LN))<210 S LN=LN_" "_DAT Q
- SAVE S X=$P(^PRCAK(430.8,+Y,1,0),U,4)
- F Q:LN="" D
- .S X=X+1
- .S ^PRCAK(430.8,+Y,1,X,0)=$E(LN,1,245)
- .S LN=$E(LN,246,9999)
- .Q
- S $P(^PRCAK(430.8,+Y,1,0),U,3,4)=X_"^"_X
- S LN=DAT
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAKBT1 3766 printed Jan 18, 2025@02:41:25 Page 2
- PRCAKBT1 ;WASH-ISC@ALTOONA,PA/CMS-AR BUILD TEMP ARCHIVE FILE CONT. ;7/3/96 11:17 AM
- V ;;4.5;Accounts Receivable;**46**;Mar 20, 1995
- +1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 NEW DA,DIC,DIQ,DR,FIL,II,PRCABN
- +3 FOR PRCABN=0:0
- SET PRCABN=$ORDER(^PRCA(430,"AC",STAT,PRCABN))
- if 'PRCABN
- QUIT
- DO SET
- +4 QUIT
- SET ;create data records
- +1 NEW BN0,DA,PRCATN,TN
- +2 SET BN0=$GET(^PRCA(430,PRCABN,0))
- IF BN0=""
- KILL ^PRCA(430,"AC",STAT,PRCABN)
- QUIT
- +3 IF $PIECE(BN0,"^")=""
- SET ^TMP("PRCAK",$JOB,"E",^TMP("PRCAK",$JOB,"E"))="Bill number not defined for entry #"_PRCABN_" in file 430!"
- SET ^TMP("PRCAK",$JOB,"E")=^TMP("PRCAK",$JOB,"E")+1
- QUIT
- +4 IF '$DATA(^PRCA(430,"B",$PIECE(BN0,U,1),PRCABN))
- SET ^PRCA(430,"B",$PIECE(BN0,U,1),PRCABN)=""
- +5 DO P430
- IF '$DATA(^UTILITY("DIQ1",$JOB))
- SET ^TMP("PRCAK",$JOB,"E",^TMP("PRCAK",$JOB,"E"))="Could not set Archive data record for Bill NO. "_$PIECE(BN0,U)
- SET ^TMP("PRCAK",$JOB,"E")=^TMP("PRCAK",$JOB,"E")+1
- QUIT
- +6 FOR PRCATN=0:0
- SET PRCATN=$ORDER(^PRCA(433,"C",PRCABN,PRCATN))
- if 'PRCATN
- QUIT
- IF $GET(^PRCA(433,PRCATN,0))'=""
- DO P433
- +7 KILL ^UTILITY("DIQ1",$JOB)
- +8 QUIT
- P430 ;get all 430 data
- +1 NEW DA,DIC,DIQ,DR,II,SF,SN,TN
- +2 KILL ^UTILITY("DIQ1",$JOB)
- +3 FOR II=2,5,10,101
- IF $DATA(^PRCA(430,PRCABN,II,0))
- Begin DoDot:1
- +4 FOR SN=0:0
- SET SN=$ORDER(^PRCA(430,PRCABN,II,SN))
- if 'SN
- QUIT
- SET SF(II,SN)=""
- End DoDot:1
- +5 SET DA=PRCABN
- SET DIC="^PRCA(430,"
- SET DIQ(0)="EN"
- SET DR=".001:99999999"
- DO EN^DIQ1
- +6 SET DR(430.01)=DR
- SET DR(430.02)=DR
- SET DR(430.051)=DR
- SET DR(430.098)=DR
- +7 FOR II=0:0
- SET II=$ORDER(SF(II))
- if 'II
- QUIT
- FOR SN=0:0
- SET SN=$ORDER(SF(II,SN))
- if 'SN
- QUIT
- SET DA($SELECT(II=2:430.01,II=5:430.051,II=10:430.098,1:430.02))=SN
- SET DIQ(0)="EN"
- DO EN^DIQ1
- +8 IF $DATA(^UTILITY("DIQ1",$JOB))
- SET TN=0
- DO ENT
- +9 QUIT
- P433 ;Get all 433 data
- +1 NEW DA,DIC,DIQ,DR,II,SF,SN
- +2 KILL ^UTILITY("DIQ1",$JOB)
- +3 FOR II=4,6,7
- IF $DATA(^PRCA(433,PRCATN,II,0))
- Begin DoDot:1
- +4 FOR SN=0:0
- SET SN=$ORDER(^PRCA(433,PRCATN,II,SN))
- if 'SN
- QUIT
- SET SF(II,SN)=""
- End DoDot:1
- +5 SET DA=PRCATN
- SET DIC="^PRCA(433,"
- SET DIQ(0)="EN"
- SET DR=".001:99999999"
- DO EN^DIQ1
- +6 SET DR(433.01)=DR
- SET DR(433.04)=DR
- SET DR(433.061)=DR
- +7 FOR II=0:0
- SET II=$ORDER(SF(II))
- if 'II
- QUIT
- FOR SN=0:0
- SET SN=$ORDER(SF(II,SN))
- if 'SN
- QUIT
- SET DA($SELECT(II=4:433.01,II=6:433.061,1:433.04))=SN
- SET DIQ(0)="EN"
- DO EN^DIQ1
- +8 IF '$DATA(^UTILITY("DIQ1",$JOB))
- SET ^TMP("PRCAK",$JOB,"E",^TMP("PRCAK",$JOB,"E"))="Could not create Archive data record for Tran. No. "_PRCABN_" of Bill # "_$PIECE(BN0,"^")
- SET ^TMP("PRCAK",$JOB,"E")=^TMP("PRCAK",$JOB,"E")+1
- QUIT
- +9 SET TN=$GET(TN)+1
- DO ENT
- +10 QUIT
- ENT ;Enter Data records in File 430.8
- +1 NEW DAT,DD,DIC,DINUM,DLAYGO,DO,FIL,FLD,I,IFN,X,Y,LN
- +2 SET DLAYGO=430.8
- SET DIC="^PRCAK(430.8,"
- SET DIC(0)="L"
- +3 SET DIC("W")=""
- SET X=$PIECE(BN0,"^",1)_"-"_TN
- DO ^DIC
- +4 IF Y<0
- SET ^TMP("PRCAK",$JOB,"E",^TMP("PRCAK",$JOB,"E"))="Could not archive entry "_X_" (IEN: "_PRCABN_") due to invalid identifier."
- SET ^TMP("PRCAK",$JOB,"E")=^TMP("PRCAK",$JOB,"E")+1
- QUIT
- +5 IF '$PIECE(Y,"^",3)
- SET ^TMP("PRCAK",$JOB,"E",^TMP("PRCAK",$JOB,"E"))="Could not archive entry "_X_" (IEN: "_PRCABN_") due to duplicate entry."
- SET ^TMP("PRCAK",$JOB,"E")=^TMP("PRCAK",$JOB,"E")+1
- QUIT
- +6 SET CNT=$GET(CNT)+1
- SET $PIECE(^PRCAK(430.8,+Y,0),"^",2)=$$NAM^RCFN01($PIECE(BN0,"^",9))
- +7 SET $PIECE(^PRCAK(430.8,+Y,0),"^",3)=$$SSN^RCFN01($PIECE(BN0,"^",9))
- SET $PIECE(^(0),"^",4)=0
- +8 SET ^PRCAK(430.8,+Y,1,0)="^^0^0^"_DT_"^"
- +9 SET FIL=""
- FOR
- SET FIL=$ORDER(^UTILITY("DIQ1",$JOB,FIL))
- if FIL=""
- QUIT
- FOR IFN=0:0
- SET IFN=$ORDER(^UTILITY("DIQ1",$JOB,FIL,IFN))
- if 'IFN
- QUIT
- Begin DoDot:1
- +10 SET FLD=""
- FOR
- SET FLD=$ORDER(^UTILITY("DIQ1",$JOB,FIL,IFN,FLD))
- if FLD=""
- QUIT
- SET I=$ORDER(^(FLD,""))
- Begin DoDot:2
- +11 IF I="E"
- SET DAT=$GET(^TMP("PRCAK",$JOB,"F",FIL,FLD))_":"_^UTILITY("DIQ1",$JOB,FIL,IFN,FLD,"E")
- DO ADD
- IF FIL=433
- IF FLD=.01
- SET $PIECE(^PRCAK(430.8,+Y,0),U,4)=$PIECE(DAT,":",2)
- QUIT
- +12 SET I=0
- FOR
- SET I=$ORDER(^UTILITY("DIQ1",$JOB,FIL,IFN,FLD,I))
- if 'I
- QUIT
- SET DAT=$GET(^TMP("PRCAK",$JOB,"F",FIL,FLD))_":"_^UTILITY("DIQ1",$JOB,FIL,IFN,FLD,I)
- DO ADD
- End DoDot:2
- +13 SET DAT=""
- DO SAVE
- End DoDot:1
- +14 QUIT
- ADD ;add to WP field
- +1 IF $GET(LN)=""
- SET LN=" "_DAT
- QUIT
- +2 IF ($LENGTH(DAT)+$LENGTH(LN))<210
- SET LN=LN_" "_DAT
- QUIT
- SAVE SET X=$PIECE(^PRCAK(430.8,+Y,1,0),U,4)
- +1 FOR
- if LN=""
- QUIT
- Begin DoDot:1
- +2 SET X=X+1
- +3 SET ^PRCAK(430.8,+Y,1,X,0)=$EXTRACT(LN,1,245)
- +4 SET LN=$EXTRACT(LN,246,9999)
- +5 QUIT
- End DoDot:1
- +6 SET $PIECE(^PRCAK(430.8,+Y,1,0),U,3,4)=X_"^"_X
- +7 SET LN=DAT
- +8 QUIT