- 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 Jan 18, 2025@02:40:32 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