PRCADR ;SF-ISC/YJK-PRINT ADDRESS,TRANS.,BALANCE ; 22 Jul 2014 6:53 AM
V ;;4.5;Accounts Receivable;**21,45,108,141,241,301**;Mar 20, 1995;Build 144
;;Per VHA Directive 10-93-142, this routine should not be modified.
;print debtor's 3rd party address,transaction,balances.
EN1 ;PRINT ADDRESS, SOCIAL SECURITY NUMBER AND DATE OF BIRTH.
N RCDMC,RCTOP,RCKAT,RCTCSP,PRCA15,Y
K PRCAGL D EN11 Q:'$D(PRCAGL) D WR1^PRCADR2
I $D(^PRCA(430,D0,8)),$P(^(8),U,7)["N" W !,"* UNABLE TO LOCATE *"
S PRCA15=$G(^PRCA(430,D0,15)) D
.I $P(PRCA15,U,2)]"" W !,"CS Recall Reason: ",$E($$GET1^DIQ(430,D0,154),1,31) W ?51,"CS Recall Date: " S Y=$P(PRCA15,U,3) D DD^%DT W Y ;prca*4.5*301
.I $P(PRCA15,U,4)]"",$P(PRCA15,U,2)="" W !,"CS Recall Reason: ",$E($$GET1^DIQ(430,D0,154),1,31) W ?51,"CS Recall Date: " ;prca*4.5*301
D END1 Q
EN11 Q:'$D(D0) S Z0=$S($P(^PRCA(430,D0,0),U,9)'="":$P(^(0),U,9),1:"") Q:Z0=""
EN12 S PRCADB=$P(^RCD(340,Z0,0),"^"),RCDMC=$D(^RCD(340,"DMC",1,Z0)),RCTOP=$D(^RCD(340,"TOP",Z0)),RCTCSP=$D(^RCD(340,"TCSP",Z0))
S X=$$DADD^RCAMADD(PRCADB) S $P(PRCAGL,"^",1,6)=$P(X,"^",1,6),$P(PRCAGL,"^",9)=$P(X,"^",7) K PRCADB
S Z1=$P(^RCD(340,Z0,0),";",1),Z2=$P($P(^(0),"^"),";",2),PRCASTE=$P(PRCAGL,U,5)
S (PRCASSN,PRCADOB)="" I '$D(^VA(200,Z1,0)),'$D(^DPT(Z1,0)) Q
S DFN=Z1 D DEM^VADPT I VAERR K VAERR Q
S PRCASSN=$S(Z2["VA(200":$P(^VA(200,Z1,1),U,9),1:"")
I Z2["DPT(" S DFN=Z1 D DEM^VADPT S PRCASSN=$P(VADM(2),"^",2)
S RCKAT="" I $$EMGRES^DGUTL(DFN)["K" S RCKAT=1
S PRCASSN=$S((PRCASSN["-")!($L(PRCASSN)>9):PRCASSN,1:$E(PRCASSN,1,3)_"-"_$E(PRCASSN,4,5)_"-"_$E(PRCASSN,6,9))
S PRCADOB=$S(Z2["VA(200":$P(^VA(200,Z1,1),U,3),Z2["DPT":$P(VADM(3),"^",1),1:"")
S PRCADOB=$$SLH^RCFN01(PRCADOB) K DFN,VAERR,VADM,Z1,Z2 Q
END1 K %,PRCADOB,PRCASSN,PRCASTE,PRCAGL,Z1,Z2,Z0 Q
EN2 ;prints all transaction type of AR in the Profile of AR.
Q:'$D(D0) S PRCAEN=0,PRCAK1=1 K PRCA("WROFF")
F I=0:0 S PRCAEN=$O(^PRCA(433,"C",D0,PRCAEN)) Q:'PRCAEN D WR2^PRCADR2 S PRCAK1=PRCAK1+1 I PRCAK1>7 D EN5 Q:$D(PRCA("HALT")) S PRCAK1=-5
END2 K I,PRCAEN,PRCAK1,PRCAG,% Q ;end of EN2
EN3 ;Print the balances and paid amount of Principal,Interest and Admin.
PRBAL S (PRCAK("PB"),PRCAK("IB"),PRCAK("AB"),PRCAK("IP"),PRCAK("PP"),PRCAK("AP"),PRCAK("MF"),PRCAK("CC"))=0
I $D(^PRCA(430,D0,7)) D PRBAL1
S (PRCAL(1),PRCAL(2),PRCAL(3),PRCAL(4),PRCAL(5),PRCAL(6),PRCACODE)=""
I $D(^PRCA(430,D0,6)) S PRCAGL6=^(6),PRCAL(1)=$P(PRCAGL6,U,1),PRCAL(2)=$P(PRCAGL6,U,2),PRCAL(3)=$P(PRCAGL6,U,3),PRCAL(4)=$P(PRCAGL6,U,4),PRCACODE=$P(PRCAGL6,U,5),PRCAL(5)=$P(PRCAGL6,U,7),PRCAL(6)=$P(PRCAGL6,U,14)
S PRCACODE=$S(PRCACODE]"""":PRCACODE,1:"DC/DOJ")
S PRCALT=PRCAL(1) D LDATE S PRCAL(1)=PRCALT,PRCALT=PRCAL(2) D LDATE S PRCAL(2)=PRCALT,PRCALT=PRCAL(3) D LDATE S PRCAL(3)=PRCALT
S PRCALT=PRCAL(4) D LDATE S PRCAL(4)=PRCALT,PRCALT=PRCAL(5) D LDATE S PRCAL(5)=PRCALT,PRCALT=PRCAL(6) D LDATE S PRCAL(6)=PRCALT
D WR3^PRCADR2
END3 K PRCAL,PRCACODE,PRCALT,PRCAGL6,PRCAGL7,PRCAK Q
PRBAL1 S PRCAGL7=^PRCA(430,D0,7),PRCAK("PP")=$P(PRCAGL7,U,7),PRCAK("IP")=$P(PRCAGL7,U,8),PRCAK("AP")=$P(PRCAGL7,U,9)
S PRCAK("PB")=$P(PRCAGL7,U,1),PRCAK("IB")=$P(PRCAGL7,U,2),PRCAK("AB")=$P(PRCAGL7,U,3),PRCAK("MF")=$P(PRCAGL7,U,4),PRCAK("CC")=$P(PRCAGL7,U,5)
Q
LDATE Q:PRCALT="" S PRCALT=$$SLH^RCFN01(PRCALT) Q
EN4 ;Print 3rd party address information.
Q:'$D(D0) S Z0=$S($P(^PRCA(430,D0,0),U,9)'="":$P(^(0),U,9),1:"") Q:Z0="" S PRCADB=$P(^RCD(340,Z0,0),"^") S X=$$DADD^RCAMADD(PRCADB) S $P(PRCAGL,"^",1,6)=$P(X,"^",1,6),$P(PRCAGL,"^",9)=$P(X,"^",7) K PRCADB
W !,?12,$P(PRCAGL,U) F X=2,3,4 W:$P(PRCAGL,U,X)'="" !,?12,$P(PRCAGL,U,X)
I $P(PRCAGL,U,5)'="",$P(PRCAGL,U,5)'[" " W ", ",$P(PRCAGL,U,5)," ",$P(PRCAGL,U,6)
W " PHONE NO.: ",$P(PRCAGL,U,9)
END4 K %,PRCAGL,Z0 Q
EN5 K PRCA("HALT") Q:'$D(PRCAIO)
I $E(IOST,1,2)["C-" R !,?8,"ENTER '^' TO HALT: ",X:$S($D(DTIME):DTIME,1:999) I (X["^")!('$T) S PRCA("HALT")=1 Q
I $E(IOST,1,2)["C-",$D(IOF) W @IOF
Q
;
SVDT(D0) ;Called from the PRCA 3RD PROFILE print template
N X S X="IBRFN" X ^%ZOSF("TEST") G SVDTQ:'$T
S D0=$P($P($G(^PRCA(430,+D0,0)),"^"),"-",2)
S X=$$SVDT^IBRFN(D0)
Q X
SVDTQ Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCADR 4154 printed Apr 09, 2024@20:49:45 Page 2
PRCADR ;SF-ISC/YJK-PRINT ADDRESS,TRANS.,BALANCE ; 22 Jul 2014 6:53 AM
V ;;4.5;Accounts Receivable;**21,45,108,141,241,301**;Mar 20, 1995;Build 144
+1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;print debtor's 3rd party address,transaction,balances.
EN1 ;PRINT ADDRESS, SOCIAL SECURITY NUMBER AND DATE OF BIRTH.
+1 NEW RCDMC,RCTOP,RCKAT,RCTCSP,PRCA15,Y
+2 KILL PRCAGL
DO EN11
if '$DATA(PRCAGL)
QUIT
DO WR1^PRCADR2
+3 IF $DATA(^PRCA(430,D0,8))
IF $PIECE(^(8),U,7)["N"
WRITE !,"* UNABLE TO LOCATE *"
+4 SET PRCA15=$GET(^PRCA(430,D0,15))
Begin DoDot:1
+5 ;prca*4.5*301
IF $PIECE(PRCA15,U,2)]""
WRITE !,"CS Recall Reason: ",$EXTRACT($$GET1^DIQ(430,D0,154),1,31)
WRITE ?51,"CS Recall Date: "
SET Y=$PIECE(PRCA15,U,3)
DO DD^%DT
WRITE Y
+6 ;prca*4.5*301
IF $PIECE(PRCA15,U,4)]""
IF $PIECE(PRCA15,U,2)=""
WRITE !,"CS Recall Reason: ",$EXTRACT($$GET1^DIQ(430,D0,154),1,31)
WRITE ?51,"CS Recall Date: "
End DoDot:1
+7 DO END1
QUIT
EN11 if '$DATA(D0)
QUIT
SET Z0=$SELECT($PIECE(^PRCA(430,D0,0),U,9)'="":$PIECE(^(0),U,9),1:"")
if Z0=""
QUIT
EN12 SET PRCADB=$PIECE(^RCD(340,Z0,0),"^")
SET RCDMC=$DATA(^RCD(340,"DMC",1,Z0))
SET RCTOP=$DATA(^RCD(340,"TOP",Z0))
SET RCTCSP=$DATA(^RCD(340,"TCSP",Z0))
+1 SET X=$$DADD^RCAMADD(PRCADB)
SET $PIECE(PRCAGL,"^",1,6)=$PIECE(X,"^",1,6)
SET $PIECE(PRCAGL,"^",9)=$PIECE(X,"^",7)
KILL PRCADB
+2 SET Z1=$PIECE(^RCD(340,Z0,0),";",1)
SET Z2=$PIECE($PIECE(^(0),"^"),";",2)
SET PRCASTE=$PIECE(PRCAGL,U,5)
+3 SET (PRCASSN,PRCADOB)=""
IF '$DATA(^VA(200,Z1,0))
IF '$DATA(^DPT(Z1,0))
QUIT
+4 SET DFN=Z1
DO DEM^VADPT
IF VAERR
KILL VAERR
QUIT
+5 SET PRCASSN=$SELECT(Z2["VA(200":$PIECE(^VA(200,Z1,1),U,9),1:"")
+6 IF Z2["DPT("
SET DFN=Z1
DO DEM^VADPT
SET PRCASSN=$PIECE(VADM(2),"^",2)
+7 SET RCKAT=""
IF $$EMGRES^DGUTL(DFN)["K"
SET RCKAT=1
+8 SET PRCASSN=$SELECT((PRCASSN["-")!($LENGTH(PRCASSN)>9):PRCASSN,1:$EXTRACT(PRCASSN,1,3)_"-"_$EXTRACT(PRCASSN,4,5)_"-"_$EXTRACT(PRCASSN,6,9))
+9 SET PRCADOB=$SELECT(Z2["VA(200":$PIECE(^VA(200,Z1,1),U,3),Z2["DPT":$PIECE(VADM(3),"^",1),1:"")
+10 SET PRCADOB=$$SLH^RCFN01(PRCADOB)
KILL DFN,VAERR,VADM,Z1,Z2
QUIT
END1 KILL %,PRCADOB,PRCASSN,PRCASTE,PRCAGL,Z1,Z2,Z0
QUIT
EN2 ;prints all transaction type of AR in the Profile of AR.
+1 if '$DATA(D0)
QUIT
SET PRCAEN=0
SET PRCAK1=1
KILL PRCA("WROFF")
+2 FOR I=0:0
SET PRCAEN=$ORDER(^PRCA(433,"C",D0,PRCAEN))
if 'PRCAEN
QUIT
DO WR2^PRCADR2
SET PRCAK1=PRCAK1+1
IF PRCAK1>7
DO EN5
if $DATA(PRCA("HALT"))
QUIT
SET PRCAK1=-5
END2 ;end of EN2
KILL I,PRCAEN,PRCAK1,PRCAG,%
QUIT
EN3 ;Print the balances and paid amount of Principal,Interest and Admin.
PRBAL SET (PRCAK("PB"),PRCAK("IB"),PRCAK("AB"),PRCAK("IP"),PRCAK("PP"),PRCAK("AP"),PRCAK("MF"),PRCAK("CC"))=0
+1 IF $DATA(^PRCA(430,D0,7))
DO PRBAL1
+2 SET (PRCAL(1),PRCAL(2),PRCAL(3),PRCAL(4),PRCAL(5),PRCAL(6),PRCACODE)=""
+3 IF $DATA(^PRCA(430,D0,6))
SET PRCAGL6=^(6)
SET PRCAL(1)=$PIECE(PRCAGL6,U,1)
SET PRCAL(2)=$PIECE(PRCAGL6,U,2)
SET PRCAL(3)=$PIECE(PRCAGL6,U,3)
SET PRCAL(4)=$PIECE(PRCAGL6,U,4)
SET PRCACODE=$PIECE(PRCAGL6,U,5)
SET PRCAL(5)=$PIECE(PRCAGL6,U,7)
SET PRCAL(6)=$PIECE(PRCAGL6,U,14)
+4 SET PRCACODE=$SELECT(PRCACODE]"""":PRCACODE,1:"DC/DOJ")
+5 SET PRCALT=PRCAL(1)
DO LDATE
SET PRCAL(1)=PRCALT
SET PRCALT=PRCAL(2)
DO LDATE
SET PRCAL(2)=PRCALT
SET PRCALT=PRCAL(3)
DO LDATE
SET PRCAL(3)=PRCALT
+6 SET PRCALT=PRCAL(4)
DO LDATE
SET PRCAL(4)=PRCALT
SET PRCALT=PRCAL(5)
DO LDATE
SET PRCAL(5)=PRCALT
SET PRCALT=PRCAL(6)
DO LDATE
SET PRCAL(6)=PRCALT
+7 DO WR3^PRCADR2
END3 KILL PRCAL,PRCACODE,PRCALT,PRCAGL6,PRCAGL7,PRCAK
QUIT
PRBAL1 SET PRCAGL7=^PRCA(430,D0,7)
SET PRCAK("PP")=$PIECE(PRCAGL7,U,7)
SET PRCAK("IP")=$PIECE(PRCAGL7,U,8)
SET PRCAK("AP")=$PIECE(PRCAGL7,U,9)
+1 SET PRCAK("PB")=$PIECE(PRCAGL7,U,1)
SET PRCAK("IB")=$PIECE(PRCAGL7,U,2)
SET PRCAK("AB")=$PIECE(PRCAGL7,U,3)
SET PRCAK("MF")=$PIECE(PRCAGL7,U,4)
SET PRCAK("CC")=$PIECE(PRCAGL7,U,5)
+2 QUIT
LDATE if PRCALT=""
QUIT
SET PRCALT=$$SLH^RCFN01(PRCALT)
QUIT
EN4 ;Print 3rd party address information.
+1 if '$DATA(D0)
QUIT
SET Z0=$SELECT($PIECE(^PRCA(430,D0,0),U,9)'="":$PIECE(^(0),U,9),1:"")
if Z0=""
QUIT
SET PRCADB=$PIECE(^RCD(340,Z0,0),"^")
SET X=$$DADD^RCAMADD(PRCADB)
SET $PIECE(PRCAGL,"^",1,6)=$PIECE(X,"^",1,6)
SET $PIECE(PRCAGL,"^",9)=$PIECE(X,"^",7)
KILL PRCADB
+2 WRITE !,?12,$PIECE(PRCAGL,U)
FOR X=2,3,4
if $PIECE(PRCAGL,U,X)'=""
WRITE !,?12,$PIECE(PRCAGL,U,X)
+3 IF $PIECE(PRCAGL,U,5)'=""
IF $PIECE(PRCAGL,U,5)'[" "
WRITE ", ",$PIECE(PRCAGL,U,5)," ",$PIECE(PRCAGL,U,6)
+4 WRITE " PHONE NO.: ",$PIECE(PRCAGL,U,9)
END4 KILL %,PRCAGL,Z0
QUIT
EN5 KILL PRCA("HALT")
if '$DATA(PRCAIO)
QUIT
+1 IF $EXTRACT(IOST,1,2)["C-"
READ !,?8,"ENTER '^' TO HALT: ",X:$SELECT($DATA(DTIME):DTIME,1:999)
IF (X["^")!('$TEST)
SET PRCA("HALT")=1
QUIT
+2 IF $EXTRACT(IOST,1,2)["C-"
IF $DATA(IOF)
WRITE @IOF
+3 QUIT
+4 ;
SVDT(D0) ;Called from the PRCA 3RD PROFILE print template
+1 NEW X
SET X="IBRFN"
XECUTE ^%ZOSF("TEST")
if '$TEST
GOTO SVDTQ
+2 SET D0=$PIECE($PIECE($GET(^PRCA(430,+D0,0)),"^"),"-",2)
+3 SET X=$$SVDT^IBRFN(D0)
+4 QUIT X
SVDTQ QUIT 0
