- 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 Feb 18, 2025@23:07:26 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