PRCAPRO ;SF-ISC/YJK-PROFILE OF ACCOUNTS RECEIVABLE ;10/17/95 2:02 PM
V ;;4.5;Accounts Receivable;**2,21,125,147,198,301**;Mar 20, 1995;Build 144
;;Per VA Directive 6402, this routine should not be modified.
;PRINT THE PROFILE OF A/R CALLING THE ROUTINES CREATED BY PRINT TEMPLATE
INIT K %ZIS,IOP,DXS S PRCABN=""
EN ;
N DPTNOFZY,DPTNOFZK S (DPTNOFZY,DPTNOFZK)=1
S DIC("S")="S Z0=$S($D(^PRCA(430.3,+$P(^(0),U,8),0)):$P(^(0),U,3),1:0) I (Z0<200)!(Z0=240)",DIC="^PRCA(430,",DIC(0)="AEMQZ",D="B^C^D^E" D MIX^DIC1 K DIC G:Y<0 END S (PRCABN,D0)=+Y
G:$P(^PRCA(430,D0,0),U,8)="" END
I $P(^PRCA(430.3,+$P(^PRCA(430,D0,0),U,8),0),U,3)=104 W *7,!,"This is a New Bill. You should audit this bill to see the profile. ",! G EN
I $P(^PRCA(430.3,+$P(^PRCA(430,D0,0),U,8),0),U,3)=101 W *7,!,"This is an Incomplete Bill. You should edit this bill to see the profile.",! G EN
S %ZIS="Q" D ^%ZIS Q:POP S IOM=80,PRCAIO=IO,PRCAIO(0)=IO(0)
I $D(IO("Q")) K IO("Q") S ZTRTN="PROC^PRCAPRO",ZTSAVE("PRCAIO(0)")=PRCAIO(0),ZTSAVE("D0")=PRCABN,ZTSAVE("PRCABN")=PRCABN,ZTSAVE("PRCAIO")=PRCAIO,ZTDESC="Profile of Accounts Receivable" D ^%ZTLOAD,CLOSE G EN
U IO D PROC,CLOSE G EN
CLOSE D ^%ZISC D END Q
PROC ;===============SUBROUTINE==========================================
S PRCAGL=^PRCA(430,D0,0) Q:+$P(PRCAGL,U,2)'>0 S PRCAT=$P(^PRCA(430.2,$P(PRCAGL,U,2),0),U,6) S:$P(PRCAGL,U,2)=$O(^PRCA(430.2,"AC",33,0)) PRBN=D0
W:IO=IO(0) @IOF
K DXS,^UTILITY($J,"W") D @$S(PRCAT="C":"^PRCATP2",PRCAT="P":"^PRCATP1","OV"[PRCAT:"^PRCATP3",PRCAT="T":"^PRCATP5",1:"^PRCATP4")
I +$G(PRBN),'$D(PRCA("HALT")) D DISP^PRCARFD(PRBN)
W !! K PRBN,PRCAIO,ZTSAVE,ZTDTH,ZTRTN,%ZIS,IOP,DIW,DIWL,DIWR Q
END K PRCAIO,PRCABN,PRCAGL,PRCAT Q
TRANSPR ;TRANSACTION PROFILE
EN1 N DPTNOFZY,DPTNOFZK S (DPTNOFZY,DPTNOFZK)=1
K PRCAIO W ! S DIC="^PRCA(433,",DIC(0)="AEQM",DIC("A")="ENTER AR TRANSACTION NO. OR BILL NO.: " D ^DIC G:Y<0 EXIT S PRCADA=+Y
S PRCA("MESS")="Do you want to queue this output " D QUE^PRCAQUE G:'$D(PRCAQUE) EXIT S IOP=PRCA("DEV"),IOM=80,PRCAIO=IO,PRCAIO(0)=IO(0)
I IO=IO(0) D TR,CLOSE G EN1
I PRCA("DEV")["Q" S ZTRTN="TR^PRCAPRO",ZTSAVE("PRCATYP")="",ZTSAVE("PRCADA")=PRCADA,ZTSAVE("PRCAIO(0)")=PRCAIO(0),ZTSAVE("PRCAIO")=PRCAIO,ZTDESC="Transaction Profile"
I D ^%ZTLOAD,CLOSE W:(IOM-$X)<20 ! W " <REQUEST QUEUED>",*7,! D KILLV G EN1
U IO D TR,CLOSE K %ZIS,IOP,PRCAIO G EN1
TR W:$D(IOF)&($E(IOST,1,2)="C-") @IOF S Z="TRANSACTION PROFILE",Z1=(IOM/2)-($L(Z)/2) W !,?Z1,Z,! F I=1:1:78 W "="
K Z,Z1 W ! S D0=PRCADA K DXS D ^PRCATR3 K DXS S X=PRCADA D ENF^IBOLK
S PRCABN=$P($$EN^PRCAFN1(PRCADA),"^",2)
W !,"FUND: ",$P($G(^PRCA(430,PRCABN,11)),U,17),?40,"RSC: ",$P($G(^PRCA(430,PRCABN,11)),U,23)
S CAT=+$$CAT^PRCAFN1(+PRCABN)
I CAT=24 D STMT^IBRFN1(PRCADA) D:$D(^TMP("IBRFN1",$J))
.S Z=0 F S Z=$O(^TMP("IBRFN1",$J,Z)) Q:'Z S X=^(Z) D
..I $P($G(^PRCA(430,+PRCABN,0)),"^",16)=4 W !,"Visit date: ",$$FMTE^XLFDT($P(X,"^",2)) Q
..W !,"Admission date: ",$$FMTE^XLFDT($P(X,"^",2)),?30,"Discharge date: ",$$FMTE^XLFDT($P(X,"^",5))
D KILLV Q
KILLV K DIR,DIRUT,DIROUT,DUOUT,DTOUT,PRCABN,PRCATYP,DIC,%ZIS,IOP,DA,DD,E,ZTDTH,ZTRTN,ZTSAVE,PRCA,PRCADA,PRCAQUE,DXS,^TMP("IBRFN1") Q
EXIT D KILLV Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAPRO 3213 printed Dec 13, 2024@01:41:02 Page 2
PRCAPRO ;SF-ISC/YJK-PROFILE OF ACCOUNTS RECEIVABLE ;10/17/95 2:02 PM
V ;;4.5;Accounts Receivable;**2,21,125,147,198,301**;Mar 20, 1995;Build 144
+1 ;;Per VA Directive 6402, this routine should not be modified.
+2 ;PRINT THE PROFILE OF A/R CALLING THE ROUTINES CREATED BY PRINT TEMPLATE
INIT KILL %ZIS,IOP,DXS
SET PRCABN=""
EN ;
+1 NEW DPTNOFZY,DPTNOFZK
SET (DPTNOFZY,DPTNOFZK)=1
+2 SET DIC("S")="S Z0=$S($D(^PRCA(430.3,+$P(^(0),U,8),0)):$P(^(0),U,3),1:0) I (Z0<200)!(Z0=240)"
SET DIC="^PRCA(430,"
SET DIC(0)="AEMQZ"
SET D="B^C^D^E"
DO MIX^DIC1
KILL DIC
if Y<0
GOTO END
SET (PRCABN,D0)=+Y
+3 if $PIECE(^PRCA(430,D0,0),U,8)=""
GOTO END
+4 IF $PIECE(^PRCA(430.3,+$PIECE(^PRCA(430,D0,0),U,8),0),U,3)=104
WRITE *7,!,"This is a New Bill. You should audit this bill to see the profile. ",!
GOTO EN
+5 IF $PIECE(^PRCA(430.3,+$PIECE(^PRCA(430,D0,0),U,8),0),U,3)=101
WRITE *7,!,"This is an Incomplete Bill. You should edit this bill to see the profile.",!
GOTO EN
+6 SET %ZIS="Q"
DO ^%ZIS
if POP
QUIT
SET IOM=80
SET PRCAIO=IO
SET PRCAIO(0)=IO(0)
+7 IF $DATA(IO("Q"))
KILL IO("Q")
SET ZTRTN="PROC^PRCAPRO"
SET ZTSAVE("PRCAIO(0)")=PRCAIO(0)
SET ZTSAVE("D0")=PRCABN
SET ZTSAVE("PRCABN")=PRCABN
SET ZTSAVE("PRCAIO")=PRCAIO
SET ZTDESC="Profile of Accounts Receivable"
DO ^%ZTLOAD
DO CLOSE
GOTO EN
+8 USE IO
DO PROC
DO CLOSE
GOTO EN
CLOSE DO ^%ZISC
DO END
QUIT
PROC ;===============SUBROUTINE==========================================
+1 SET PRCAGL=^PRCA(430,D0,0)
if +$PIECE(PRCAGL,U,2)'>0
QUIT
SET PRCAT=$PIECE(^PRCA(430.2,$PIECE(PRCAGL,U,2),0),U,6)
if $PIECE(PRCAGL,U,2)=$ORDER(^PRCA(430.2,"AC",33,0))
SET PRBN=D0
+2 if IO=IO(0)
WRITE @IOF
+3 KILL DXS,^UTILITY($JOB,"W")
DO @$SELECT(PRCAT="C":"^PRCATP2",PRCAT="P":"^PRCATP1","OV"[PRCAT:"^PRCATP3",PRCAT="T":"^PRCATP5",1:"^PRCATP4")
+4 IF +$GET(PRBN)
IF '$DATA(PRCA("HALT"))
DO DISP^PRCARFD(PRBN)
+5 WRITE !!
KILL PRBN,PRCAIO,ZTSAVE,ZTDTH,ZTRTN,%ZIS,IOP,DIW,DIWL,DIWR
QUIT
END KILL PRCAIO,PRCABN,PRCAGL,PRCAT
QUIT
TRANSPR ;TRANSACTION PROFILE
EN1 NEW DPTNOFZY,DPTNOFZK
SET (DPTNOFZY,DPTNOFZK)=1
+1 KILL PRCAIO
WRITE !
SET DIC="^PRCA(433,"
SET DIC(0)="AEQM"
SET DIC("A")="ENTER AR TRANSACTION NO. OR BILL NO.: "
DO ^DIC
if Y<0
GOTO EXIT
SET PRCADA=+Y
+2 SET PRCA("MESS")="Do you want to queue this output "
DO QUE^PRCAQUE
if '$DATA(PRCAQUE)
GOTO EXIT
SET IOP=PRCA("DEV")
SET IOM=80
SET PRCAIO=IO
SET PRCAIO(0)=IO(0)
+3 IF IO=IO(0)
DO TR
DO CLOSE
GOTO EN1
+4 IF PRCA("DEV")["Q"
SET ZTRTN="TR^PRCAPRO"
SET ZTSAVE("PRCATYP")=""
SET ZTSAVE("PRCADA")=PRCADA
SET ZTSAVE("PRCAIO(0)")=PRCAIO(0)
SET ZTSAVE("PRCAIO")=PRCAIO
SET ZTDESC="Transaction Profile"
+5 IF $TEST
DO ^%ZTLOAD
DO CLOSE
if (IOM-$X)<20
WRITE !
WRITE " <REQUEST QUEUED>",*7,!
DO KILLV
GOTO EN1
+6 USE IO
DO TR
DO CLOSE
KILL %ZIS,IOP,PRCAIO
GOTO EN1
TR if $DATA(IOF)&($EXTRACT(IOST,1,2)="C-")
WRITE @IOF
SET Z="TRANSACTION PROFILE"
SET Z1=(IOM/2)-($LENGTH(Z)/2)
WRITE !,?Z1,Z,!
FOR I=1:1:78
WRITE "="
+1 KILL Z,Z1
WRITE !
SET D0=PRCADA
KILL DXS
DO ^PRCATR3
KILL DXS
SET X=PRCADA
DO ENF^IBOLK
+2 SET PRCABN=$PIECE($$EN^PRCAFN1(PRCADA),"^",2)
+3 WRITE !,"FUND: ",$PIECE($GET(^PRCA(430,PRCABN,11)),U,17),?40,"RSC: ",$PIECE($GET(^PRCA(430,PRCABN,11)),U,23)
+4 SET CAT=+$$CAT^PRCAFN1(+PRCABN)
+5 IF CAT=24
DO STMT^IBRFN1(PRCADA)
if $DATA(^TMP("IBRFN1",$JOB))
Begin DoDot:1
+6 SET Z=0
FOR
SET Z=$ORDER(^TMP("IBRFN1",$JOB,Z))
if 'Z
QUIT
SET X=^(Z)
Begin DoDot:2
+7 IF $PIECE($GET(^PRCA(430,+PRCABN,0)),"^",16)=4
WRITE !,"Visit date: ",$$FMTE^XLFDT($PIECE(X,"^",2))
QUIT
+8 WRITE !,"Admission date: ",$$FMTE^XLFDT($PIECE(X,"^",2)),?30,"Discharge date: ",$$FMTE^XLFDT($PIECE(X,"^",5))
End DoDot:2
End DoDot:1
+9 DO KILLV
QUIT
KILLV KILL DIR,DIRUT,DIROUT,DUOUT,DTOUT,PRCABN,PRCATYP,DIC,%ZIS,IOP,DA,DD,E,ZTDTH,ZTRTN,ZTSAVE,PRCA,PRCADA,PRCAQUE,DXS,^TMP("IBRFN1")
QUIT
EXIT DO KILLV
QUIT
