Routine: PRCAPCL

PRCAPCL ;WASH-ISC@ALTOONA,PA/NYB - Print Bill Status Report ;8/19/94  10:21 AM

V ;;4.5;Accounts Receivable;**72,63,143,154,315,342,368,391,389**;Mar 20, 1995;Build 36

 ;;Per VA Directive 6402, this routine should not be modified.

 ;PRCA*4.5*368 Instead of relying on the suspended tx for a bill

 ;             loop in reverse until the newest suspended tx is found

 N BAL,BN,CAT,DEAD,DEBT,DIR,DIROUT,DUOUT,DP,DP2,HDR,IOP,N430

 N PAGE,POP,PRCAE,PRCATOT,PRCATOT2,PRCAT,PRCAT2,PRCY,RCDOJ,TDT,ST,STT

 S (PAGE,PRCAT,PRCAT2,PRCATOT,PRCATOT2,HDR)=0

 D NOW^%DTC S Y=% X ^DD("DD") S TDT=Y

 I $G(STAT)="ALL" S STT=0 F  S STT=($O(^PRCA(430.3,"AC",STT))) Q:STT=""  D

 . I STT<100!(STT=107) Q

 . S STAT($O(^PRCA(430.3,"AC",STT,0)))=""

. Q

 S STAT=0 F  S STAT=$O(STAT(STAT)) Q:STAT=""!($D(DIROUT))!($D(DUOUT))  D

 . N NDE

 . D HDR

 . F PRCAE=0:0 S PRCAE=$O(^PRCA(430,"AC",STAT,PRCAE)),X="" Q:'PRCAE!($D(DIROUT)!($D(DUOUT)))  I $P($G(^PRCA(430,PRCAE,100)),"^",2)[$G(SER),$S($G(SER):+$G(^PRCA(430,PRCAE,100)),1:1) D  Q:$D(DIROUT)!($D(DUOUT))  D PRNTL

 .. I $Y+4>IOSL D TOP,HDR

 . I $Y+4>IOSL D TOP,HDR Q:$D(DIROUT)!($D(DUOUT))

 . S DP2=$S(+$P($G(DAT),"^",2)=0:"",1:+$P($G(DAT),"^",2))

 . S ST="" F  S ST=$O(^TMP($J,"PRCAE",ST)) Q:ST=""!($D(DIROUT)!($D(DUOUT)))  D

 .. I STAT=40 D STHDR

 .. S DP=0 F  S DP=$O(^TMP($J,"PRCAE",ST,DP)) Q:'DP!($D(DIROUT)!($D(DUOUT)))  D

 ... S BN="" F  S BN=$O(^TMP($J,"PRCAE",ST,DP,BN)) Q:BN=""!($D(DIROUT)!($D(DUOUT)))  D

 .... S NDE=^TMP($J,"PRCAE",ST,DP,BN)

 .... S Y=DP X ^DD("DD") S DP2=Y K Y

 .... S RCDOJ=$$REFST^RCRCUTL(+$O(^PRCA(430,"B",BN,0)))

 .... W $G(DP2),?15,$S(RCDOJ&$G(BN):$G(BN)_"r",1:$G(BN)),?30,$P(NDE,U,2),?45,$P(NDE,U,3)

 .... W ?65,$J($P(NDE,U,4),9,2),!

 .... S PRCATOT2=PRCATOT2+$P(NDE,U,4),PRCAT2=PRCAT2+1

 .... S PRCATOT=PRCATOT+$P(NDE,U,4),PRCAT=PRCAT+1

 .... I $Y+4>IOSL D TOP,HDR Q:$D(DIROUT)!($D(DUOUT))  I STAT=40 D STHDR

 .... K ^TMP($J,"PRCAE",ST,DP,BN)

 . I X'="^" W !!!,"SUBTOTAL: ",$J(PRCATOT2,10,2),!,"SUBCOUNT: ",$J(PRCAT2,10),?30 Q:$D(DIROUT)!($D(DUOUT))

 . S (PRCATOT2,PRCAT2)=0

 . Q:$D(DIROUT)!($D(DUOUT))

 . I $O(STAT(STAT))="" Q

 . I $O(STAT(STAT))'="" W !! D TOP

 I X'="^" W !!!,"TOTAL: ",$J(PRCATOT,10,2),!,"COUNT: ",$J(PRCAT,10),!," MEAN: ",$J($S('PRCAT:0,1:PRCATOT/PRCAT),10,2),?30,"* -indicates that patient is deceased",!,?30,"r -indicates that bill is referred"

 W:$E(IOST)="P" @IOF Q

TOP ;

 I $E(IOST)="C" S X="" S DIR(0)="E" D ^DIR Q:$D(DIROUT)!($D(DUOUT))

Q2 Q

PRNTL ;

 N BAL,DFN,DEAD,DEBT,ST

 S X=$S($D(^PRCA(430,PRCAE,0)):^(0),1:"") G:X="" PQ

 S BN=$P($G(X),U),DP=$P($G(X),U,14),PRCY=$P($G(X),U,2) G:BN="" PQ

 S BEG=+DAT-1,END=+$P(DAT,U,2)

 S ST=12 I STAT=40 D SUST ;PRCA*4.5*315/DRF Find suspended type

 I BEG,DP'>BEG Q

 I END,DP>END Q

 I STAT=40,PRSELST'="",PRSELST'="A",PRSELST'[(","_ST_",") Q  ; Quit if suspended type is not selected  PRCA*4.5*391

 S (CAT,PRCY)=$S(PRCY="":PRCY,$D(^PRCA(430.2,PRCY,0))#2:$P(^(0),U),1:PRCY)

 S PRCY=$S($D(^RCD(340,+$P(X,U,9),0)):$P(^(0),U),1:"")

 I PRCY["DPT" S DFN=+PRCY D DEM^VADPT S:+VADM(6) DEAD="*" D KVAR^VADPT K VA,VADM

 I PRCY]"" S (DEBT,PRCY)=$S($D(@("^"_$P(PRCY,";",2)_+PRCY_",0)")):^(0),1:"")

 S PRCY=$S($D(^PRCA(430,PRCAE,7)):^(7),1:"")

 I 'PRCY,(STAT=$O(^PRCA(430.3,"AC",104,0))!((STAT=20)&($G(^PRCA(430,PRCAE,100)))))

 S (BAL,PRCY)=$P(PRCY,U)+$P(PRCY,U,2)+$P(PRCY,U,3)+$P(PRCY,U,4)+$P(PRCY,U,5)

 I DP'="" S ^TMP($J,"PRCAE",ST,DP,BN)=U_$E(CAT,1,13)_U_$G(DEAD)_$E($P($G(DEBT),U),1,15)_U_$G(BAL)_U_$G(PRCATOT2)_U_$G(PRCAT2)

 I $G(SER),(STAT=31!(STAT=32)) S Y=$G(^PRCA(430,PRCAE,3)) D

 . W:$P(Y,U)]"" !,"Date: ",$E($P(Y,U),4,5),"/",$E($P(Y,U),6,7),"/",$E($P(Y,U),2,3)

 . W:$P(Y,U,2)]"" "  By: ",$P($G(^VA(200,+$P(Y,U,2),0)),U)

 . W:$P(Y,U,6)]"" "  Reason: ",$P(Y,U,6)

. Q

 I $E(IOST)="",$Y+4>IOSL D TOP

PQ Q

HDR ;

 I $E(IOST)="C"!PAGE W @IOF

 S PAGE=PAGE+1

 W !,"BILL STATUS LISTING REPORT"

 W ?40,$G(TDT),?72,$G(PAGE)

 W !,"Sort Criteria for Date Last Updated Range: "_SC1_" to "_SC2

 W !,"Date Last",!," Updated",?15,"Bill no.",?30,"Category"

 W ?50,"Debtor",?68,"Balance",!

 S X="",$P(X,"-",IOM-1)="" W X,!

 W !,?5,"Status: ",$P($S($D(^PRCA(430.3,STAT,0)):^(0),1:""),U)

 S HDR=1

 W !!

DT I Y X ^DD("DD") S DP2=Y

STAT(SER) W ! ;Bill Status Listing

 N BEG,CH,DAT,END,I,PRSELST,SC1,SC2,STAT,STT,XX

 K ^TMP($J)

 S DAT=$$DATE^RCEVUTL1("")

 Q:$G(DAT)=-1

 S PRSELST=""  ; PRCA*4.5*389

 S BEG=+DAT,END=+$P(DAT,U,2)

 S SC1=$S(BEG=0:"First",1:BEG-1) I +$G(SC1) S Y=SC1+1 X ^DD("DD") S SC1=Y

 S SC2=$S(END=0:"Last",1:END) I +$G(SC2) S Y=SC2 X ^DD("DD") S SC2=Y

 D ST

 Q:STAT="^"

 D TSK,Q1

ST N DIC,X,Y

 S DIC="^PRCA(430.3,",DIC(0)="QEMZ"

 S DIC("S")="I $P(^(0),""^"",3)>100,($P(^(0),""^"",3)'=107)"

 S Y=0 W !,"STATUS: "_$S('$O(STAT("")):"ALL// ",1:"")

 R X:DTIME I '$T!(X="^") S STAT="^" Q

 I ((X="")!(X="ALL")),'$O(STAT("")) S (STAT,X)="ALL" Q

 I X="" Q

 D ^DIC S STAT=+Y,SER=$G(SER)

 I X["?" W !!,"Enter 'ALL' for all status types.",! G ST

 I STAT'="ALL",(+STAT>0) S STAT(+STAT)="" S:STAT=40 PRSELST=$$STYPSEL() G ST  ; PRCA*4.5*391

 G:+STAT<0 ST

SUST ;Look for suspended type for a suspended bill PRCA*4.5*315/DRF

 ;Look for suspended type for suspended bill even if not last bill tx   ;PRCA*4.5*368

 N PRCATX S PRCATX="A",ST=""

 F  S PRCATX=$O(^PRCA(433,"C",PRCAE,PRCATX),-1) Q:PRCATX=""  D  Q:ST  ;Quit if no transactions for this entry, PRCA*4.5*342

 .I '$D(^PRCA(433,PRCATX,1)) Q

 .I $P(^PRCA(433,PRCATX,1),U,2)'=47 Q

 .S ST=$P($G(^PRCA(433,PRCATX,1)),U,12)  ; PRCA*4.5*391

.Q

STHDR ;Display Suspended Type PRCA*4.5*315/DRF

 I 'HDR W !

 W ?30,"Suspend Type: ",$$GET1^DIQ(433.001,ST_",",.02),!!  ; PRCA*4.5*391

 S HDR=0

TSK ;

 N POP,ZTSK

 W *7,!,"Report should be QUEUED it could take some time to run!"

 S POP=0,%ZIS="MQ" D ^%ZIS G:POP Q1

 I '$D(IO("Q")) U IO D PRCAPCL U IO(0) G Q1

 S ZTRTN="^PRCAPCL"

 S (ZTSAVE("BEG"),ZTSAVE("DAT"),ZTSAVE("END"),ZTSAVE("SER"))=""

 S (ZTSAVE("STAT"),ZTSAVE("STAT("),ZTSAVE("SC1"),ZTSAVE("SC2"))=""

 S ZTSAVE("PRSELST")=""  ; PRCA*4.5*391

 S ZTDESC="Bill Status Listing" D ^%ZTLOAD

Q1 D ^%ZISC Q

STYPSEL() ; get suspension type(s) selection  PRCA*4.5*391

 ; returns comma-separated list of selected fiel 433.001 IENs, or "A" for all suspension types, or "" for no selection

 N DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y

 N RES

 S RES=""

W !

 S DIR("A")="Run for (A)ll Suspension Types or (S)elected Suspension Types: "

 S DIR("A",1)="Suspension type Selection:"

 S DIR("?")="^"

 S DIR(0)="SA^A:All;S:Selected",DIR("B")="A"

 D ^DIR I $D(DIRUT) Q RES

 I Y="A" S RES="A" Q RES  ; "All Suspension Types" selected

 S DIC(0)="ABEOMQ"

 S DIC("A")="Select Suspension Type(s): "

 S DIC="^PRCA(433.001,"

STYPSEL1 ; Prompt for suspension type selection

W !

 D ^DIC

 I $D(DUOUT)!$D(DTOUT)!(Y=-1) S RES="" Q RES

 S RES=RES_","_$P(Y,U,1)

 I $$ANOTHER G STYPSEL1

 Q RES_","

ANOTHER() ; "Select Another" prompt  PRCA*4.5*391

 ; returns 1, if response was "YES", returns 0 otherwise

 N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y

W !

 S DIR("A")="Select Another" S DIR(0)="Y",DIR("B")="NO"

 D ^DIR I $D(DIRUT) Q 0

Q Y

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAPCL   7149     printed  Mar 13, 2025@20:45:41                                                                                                                                                                                                     Page 2

PRCAPCL   ;WASH-ISC@ALTOONA,PA/NYB - Print Bill Status Report ;8/19/94  10:21 AM

V         ;;4.5;Accounts Receivable;**72,63,143,154,315,342,368,391,389**;Mar 20, 1995;Build 36

 +1       ;;Per VA Directive 6402, this routine should not be modified.

 +2       ;

 +3       ;PRCA*4.5*368 Instead of relying on the suspended tx for a bill

 +4       ;             loop in reverse until the newest suspended tx is found

 +5       ;

 +6        NEW BAL,BN,CAT,DEAD,DEBT,DIR,DIROUT,DUOUT,DP,DP2,HDR,IOP,N430

 +7        NEW PAGE,POP,PRCAE,PRCATOT,PRCATOT2,PRCAT,PRCAT2,PRCY,RCDOJ,TDT,ST,STT

 +8        SET (PAGE,PRCAT,PRCAT2,PRCATOT,PRCATOT2,HDR)=0

 +9        DO NOW^%DTC

           SET Y=%

           XECUTE ^DD("DD")

           SET TDT=Y

 +10       IF $GET(STAT)="ALL"

               SET STT=0

FOR

                   SET STT=($ORDER(^PRCA(430.3,"AC",STT)))

                   if STT=""

                       QUIT

                   Begin DoDot:1

 +11                   IF STT<100!(STT=107)

                           QUIT

 +12                   SET STAT($ORDER(^PRCA(430.3,"AC",STT,0)))=""

 +13                   QUIT

                   End DoDot:1

 +14       SET STAT=0

FOR

               SET STAT=$ORDER(STAT(STAT))

               if STAT=""!($DATA(DIROUT))!($DATA(DUOUT))

                   QUIT

               Begin DoDot:1

 +15               NEW NDE

 +16               DO HDR

 +17               FOR PRCAE=0:0

                       SET PRCAE=$ORDER(^PRCA(430,"AC",STAT,PRCAE))

                       SET X=""

                       if 'PRCAE!($DATA(DIROUT)!($DATA(DUOUT)))

                           QUIT

                       IF $PIECE($GET(^PRCA(430,PRCAE,100)),"^",2)[$GET(SER)

                           IF $SELECT($GET(SER):+$GET(^PRCA(430,PRCAE,100)),1:1)

                               Begin DoDot:2

 +18                               IF $Y+4>IOSL

                                       DO TOP

                                       DO HDR

                               End DoDot:2

                               if $DATA(DIROUT)!($DATA(DUOUT))

                                   QUIT

                               DO PRNTL

 +19               IF $Y+4>IOSL

                       DO TOP

                       DO HDR

                       if $DATA(DIROUT)!($DATA(DUOUT))

                           QUIT

 +20               SET DP2=$SELECT(+$PIECE($GET(DAT),"^",2)=0:"",1:+$PIECE($GET(DAT),"^",2))

 +21               SET ST=""

FOR

                       SET ST=$ORDER(^TMP($JOB,"PRCAE",ST))

                       if ST=""!($DATA(DIROUT)!($DATA(DUOUT)))

                           QUIT

                       Begin DoDot:2

 +22                       IF STAT=40

                               DO STHDR

 +23                       SET DP=0

FOR

                               SET DP=$ORDER(^TMP($JOB,"PRCAE",ST,DP))

                               if 'DP!($DATA(DIROUT)!($DATA(DUOUT)))

                                   QUIT

                               Begin DoDot:3

 +24                               SET BN=""

FOR

                                       SET BN=$ORDER(^TMP($JOB,"PRCAE",ST,DP,BN))

                                       if BN=""!($DATA(DIROUT)!($DATA(DUOUT)))

                                           QUIT

                                       Begin DoDot:4

 +25                                       SET NDE=^TMP($JOB,"PRCAE",ST,DP,BN)

 +26                                       SET Y=DP

                                           XECUTE ^DD("DD")

                                           SET DP2=Y

                                           KILL Y

 +27                                       SET RCDOJ=$$REFST^RCRCUTL(+$ORDER(^PRCA(430,"B",BN,0)))

 +28                                       WRITE $GET(DP2),?15,$SELECT(RCDOJ&$GET(BN):$GET(BN)_"r",1:$GET(BN)),?30,$PIECE(NDE,U,2),?45,$PIECE(NDE,U,3)

 +29                                       WRITE ?65,$JUSTIFY($PIECE(NDE,U,4),9,2),!

 +30                                       SET PRCATOT2=PRCATOT2+$PIECE(NDE,U,4)

                                           SET PRCAT2=PRCAT2+1

 +31                                       SET PRCATOT=PRCATOT+$PIECE(NDE,U,4)

                                           SET PRCAT=PRCAT+1

 +32                                       IF $Y+4>IOSL

                                               DO TOP

                                               DO HDR

                                               if $DATA(DIROUT)!($DATA(DUOUT))

                                                   QUIT

                                               IF STAT=40

                                                   DO STHDR

 +33                                       KILL ^TMP($JOB,"PRCAE",ST,DP,BN)

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

 +34               IF X'="^"

                       WRITE !!!,"SUBTOTAL: ",$JUSTIFY(PRCATOT2,10,2),!,"SUBCOUNT: ",$JUSTIFY(PRCAT2,10),?30

                       if $DATA(DIROUT)!($DATA(DUOUT))

                           QUIT

 +35               SET (PRCATOT2,PRCAT2)=0

 +36               if $DATA(DIROUT)!($DATA(DUOUT))

                       QUIT

 +37               IF $ORDER(STAT(STAT))=""

                       QUIT

 +38               IF $ORDER(STAT(STAT))'=""

                       WRITE !!

                       DO TOP

               End DoDot:1

 +39       IF X'="^"

               WRITE !!!,"TOTAL: ",$JUSTIFY(PRCATOT,10,2),!,"COUNT: ",$JUSTIFY(PRCAT,10),!," MEAN: ",$JUSTIFY($SELECT('PRCAT:0,1:PRCATOT/PRCAT),10,2),?30,"* -indicates that patient is deceased",!,?30,"r -indicates that bill is referred"

 +40       if $EXTRACT(IOST)="P"

               WRITE @IOF

           QUIT

TOP       ;

 +1        IF $EXTRACT(IOST)="C"

               SET X=""

               SET DIR(0)="E"

               DO ^DIR

               if $DATA(DIROUT)!($DATA(DUOUT))

                   QUIT

Q2         QUIT

PRNTL     ;

 +1        NEW BAL,DFN,DEAD,DEBT,ST

 +2        SET X=$SELECT($DATA(^PRCA(430,PRCAE,0)):^(0),1:"")

           if X=""

               GOTO PQ

 +3        SET BN=$PIECE($GET(X),U)

           SET DP=$PIECE($GET(X),U,14)

           SET PRCY=$PIECE($GET(X),U,2)

           if BN=""

               GOTO PQ

 +4        SET BEG=+DAT-1

           SET END=+$PIECE(DAT,U,2)

 +5       ;PRCA*4.5*315/DRF Find suspended type

           SET ST=12

           IF STAT=40

               DO SUST

 +6        IF BEG

               IF DP'>BEG

                   QUIT

 +7        IF END

               IF DP>END

                   QUIT

 +8       ; Quit if suspended type is not selected  PRCA*4.5*391

           IF STAT=40

               IF PRSELST'=""

                   IF PRSELST'="A"

                       IF PRSELST'[(","_ST_",")

                           QUIT

 +9        SET (CAT,PRCY)=$SELECT(PRCY="":PRCY,$DATA(^PRCA(430.2,PRCY,0))#2:$PIECE(^(0),U),1:PRCY)

 +10       SET PRCY=$SELECT($DATA(^RCD(340,+$PIECE(X,U,9),0)):$PIECE(^(0),U),1:"")

 +11       IF PRCY["DPT"

               SET DFN=+PRCY

               DO DEM^VADPT

               if +VADM(6)

                   SET DEAD="*"

               DO KVAR^VADPT

               KILL VA,VADM

 +12       IF PRCY]""

               SET (DEBT,PRCY)=$SELECT($DATA(@("^"_$PIECE(PRCY,";",2)_+PRCY_",0)")):^(0),1:"")

 +13       SET PRCY=$SELECT($DATA(^PRCA(430,PRCAE,7)):^(7),1:"")

 +14       IF 'PRCY

               IF (STAT=$ORDER(^PRCA(430.3,"AC",104,0))!((STAT=20)&($GET(^PRCA(430,PRCAE,100)))))

 +15       SET (BAL,PRCY)=$PIECE(PRCY,U)+$PIECE(PRCY,U,2)+$PIECE(PRCY,U,3)+$PIECE(PRCY,U,4)+$PIECE(PRCY,U,5)

 +16       IF DP'=""

               SET ^TMP($JOB,"PRCAE",ST,DP,BN)=U_$EXTRACT(CAT,1,13)_U_$GET(DEAD)_$EXTRACT($PIECE($GET(DEBT),U),1,15)_U_$GET(BAL)_U_$GET(PRCATOT2)_U_$GET(PRCAT2)

 +17       IF $GET(SER)

               IF (STAT=31!(STAT=32))

                   SET Y=$GET(^PRCA(430,PRCAE,3))

                   Begin DoDot:1

 +18                   if $PIECE(Y,U)]""

                           WRITE !,"Date: ",$EXTRACT($PIECE(Y,U),4,5),"/",$EXTRACT($PIECE(Y,U),6,7),"/",$EXTRACT($PIECE(Y,U),2,3)

 +19                   if $PIECE(Y,U,2)]""

                           WRITE "  By: ",$PIECE($GET(^VA(200,+$PIECE(Y,U,2),0)),U)

 +20                   if $PIECE(Y,U,6)]""

                           WRITE "  Reason: ",$PIECE(Y,U,6)

 +21                   QUIT

                   End DoDot:1

 +22       IF $EXTRACT(IOST)=""

               IF $Y+4>IOSL

                   DO TOP

PQ         QUIT

HDR       ;

 +1        IF $EXTRACT(IOST)="C"!PAGE

               WRITE @IOF

 +2        SET PAGE=PAGE+1

 +3        WRITE !,"BILL STATUS LISTING REPORT"

 +4        WRITE ?40,$GET(TDT),?72,$GET(PAGE)

 +5        WRITE !,"Sort Criteria for Date Last Updated Range: "_SC1_" to "_SC2

 +6        WRITE !,"Date Last",!," Updated",?15,"Bill no.",?30,"Category"

 +7        WRITE ?50,"Debtor",?68,"Balance",!

 +8        SET X=""

           SET $PIECE(X,"-",IOM-1)=""

           WRITE X,!

 +9        WRITE !,?5,"Status: ",$PIECE($SELECT($DATA(^PRCA(430.3,STAT,0)):^(0),1:""),U)

 +10       SET HDR=1

 +11       WRITE !!

 +12       QUIT

DT         IF Y

               XECUTE ^DD("DD")

               SET DP2=Y

 +1        QUIT

STAT(SER) ;Bill Status Listing

           WRITE !

 +1        NEW BEG,CH,DAT,END,I,PRSELST,SC1,SC2,STAT,STT,XX

 +2        KILL ^TMP($JOB)

 +3        SET DAT=$$DATE^RCEVUTL1("")

 +4        if $GET(DAT)=-1

               QUIT

 +5       ; PRCA*4.5*389

           SET PRSELST=""

 +6        SET BEG=+DAT

           SET END=+$PIECE(DAT,U,2)

 +7        SET SC1=$SELECT(BEG=0:"First",1:BEG-1)

           IF +$GET(SC1)

               SET Y=SC1+1

               XECUTE ^DD("DD")

               SET SC1=Y

 +8        SET SC2=$SELECT(END=0:"Last",1:END)

           IF +$GET(SC2)

               SET Y=SC2

               XECUTE ^DD("DD")

               SET SC2=Y

 +9        DO ST

 +10       if STAT="^"

               QUIT

 +11       DO TSK

           DO Q1

 +12       QUIT

ST         NEW DIC,X,Y

 +1        SET DIC="^PRCA(430.3,"

           SET DIC(0)="QEMZ"

 +2        SET DIC("S")="I $P(^(0),""^"",3)>100,($P(^(0),""^"",3)'=107)"

 +3        SET Y=0

           WRITE !,"STATUS: "_$SELECT('$ORDER(STAT("")):"ALL// ",1:"")

 +4        READ X:DTIME

           IF '$TEST!(X="^")

               SET STAT="^"

               QUIT

 +5        IF ((X="")!(X="ALL"))

               IF '$ORDER(STAT(""))

                   SET (STAT,X)="ALL"

                   QUIT

 +6        IF X=""

               QUIT

 +7        DO ^DIC

           SET STAT=+Y

           SET SER=$GET(SER)

 +8        IF X["?"

               WRITE !!,"Enter 'ALL' for all status types.",!

               GOTO ST

 +9       ; PRCA*4.5*391

           IF STAT'="ALL"

               IF (+STAT>0)

                   SET STAT(+STAT)=""

                   if STAT=40

                       SET PRSELST=$$STYPSEL()

                   GOTO ST

 +10       if +STAT<0

               GOTO ST

 +11       QUIT

 +12      ;

SUST      ;Look for suspended type for a suspended bill PRCA*4.5*315/DRF

 +1       ;Look for suspended type for suspended bill even if not last bill tx   ;PRCA*4.5*368

 +2        NEW PRCATX

           SET PRCATX="A"

           SET ST=""

 +3       ;Quit if no transactions for this entry, PRCA*4.5*342

FOR

               SET PRCATX=$ORDER(^PRCA(433,"C",PRCAE,PRCATX),-1)

               if PRCATX=""

                   QUIT

               Begin DoDot:1

 +4                IF '$DATA(^PRCA(433,PRCATX,1))

                       QUIT

 +5                IF $PIECE(^PRCA(433,PRCATX,1),U,2)'=47

                       QUIT

 +6       ; PRCA*4.5*391

                   SET ST=$PIECE($GET(^PRCA(433,PRCATX,1)),U,12)

 +7                QUIT

               End DoDot:1

               if ST

                   QUIT

 +8        QUIT

STHDR     ;Display Suspended Type PRCA*4.5*315/DRF

 +1        IF 'HDR

               WRITE !

 +2       ; PRCA*4.5*391

           WRITE ?30,"Suspend Type: ",$$GET1^DIQ(433.001,ST_",",.02),!!

 +3        SET HDR=0

 +4        QUIT

TSK       ;

 +1        NEW POP,ZTSK

 +2        WRITE *7,!,"Report should be QUEUED it could take some time to run!"

 +3        SET POP=0

           SET %ZIS="MQ"

           DO ^%ZIS

           if POP

               GOTO Q1

 +4        IF '$DATA(IO("Q"))

               USE IO

               DO PRCAPCL

               USE IO(0)

               GOTO Q1

 +5        SET ZTRTN="^PRCAPCL"

 +6        SET (ZTSAVE("BEG"),ZTSAVE("DAT"),ZTSAVE("END"),ZTSAVE("SER"))=""

 +7        SET (ZTSAVE("STAT"),ZTSAVE("STAT("),ZTSAVE("SC1"),ZTSAVE("SC2"))=""

 +8       ; PRCA*4.5*391

           SET ZTSAVE("PRSELST")=""

 +9        SET ZTDESC="Bill Status Listing"

           DO ^%ZTLOAD

Q1         DO ^%ZISC

           QUIT

 +1       ;

STYPSEL() ; get suspension type(s) selection  PRCA*4.5*391

 +1       ;

 +2       ; returns comma-separated list of selected fiel 433.001 IENs, or "A" for all suspension types, or "" for no selection

 +3       ;

 +4        NEW DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y

 +5        NEW RES

 +6        SET RES=""

 +7        WRITE !

 +8        SET DIR("A")="Run for (A)ll Suspension Types or (S)elected Suspension Types: "

 +9        SET DIR("A",1)="Suspension type Selection:"

 +10       SET DIR("?")="^"

 +11       SET DIR(0)="SA^A:All;S:Selected"

           SET DIR("B")="A"

 +12       DO ^DIR

           IF $DATA(DIRUT)

               QUIT RES

 +13      ; "All Suspension Types" selected

           IF Y="A"

               SET RES="A"

               QUIT RES

 +14       SET DIC(0)="ABEOMQ"

 +15       SET DIC("A")="Select Suspension Type(s): "

 +16       SET DIC="^PRCA(433.001,"

STYPSEL1  ; Prompt for suspension type selection

 +1        WRITE !

 +2        DO ^DIC

 +3        IF $DATA(DUOUT)!$DATA(DTOUT)!(Y=-1)

               SET RES=""

               QUIT RES

 +4        SET RES=RES_","_$PIECE(Y,U,1)

 +5        IF $$ANOTHER

               GOTO STYPSEL1

 +6        QUIT RES_","

 +7       ;

ANOTHER() ; "Select Another" prompt  PRCA*4.5*391

 +1       ; returns 1, if response was "YES", returns 0 otherwise

 +2        NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y

 +3        WRITE !

 +4        SET DIR("A")="Select Another"

           SET DIR(0)="Y"

           SET DIR("B")="NO"

 +5        DO ^DIR

           IF $DATA(DIRUT)

               QUIT 0

 +6        QUIT Y

PRCAPCL.m