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 Oct 16, 2024@17:41:02 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
