- ACRFIV ;IHS/OIRM/DSD/THL,AEF - INVOICE AUDIT; [ 11/01/2001 9:44 AM ]
- ;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
- ;;ROUTINE CALLED DURING PROCESSING OF INVOICES
- EN K ACRSST,ACRIVT,ACRSSTX,ACRIVTX,ACRIVPAY,^TMP("ACRRR",$J)
- Q:'+$G(ACRRRNOX)
- Q:'ACRVDA
- D GATHER
- D DISPLAY
- D SELECT:'$D(ACRQUIT)
- EXIT K ACRSSDT,ACRSSNMS,ACRSSDSC,ACRNOTES,ACRSSUP,ACRSSACP,ACRSSACT,ACRIVACP,ACRSSIT,ACRIVIT,ACRSST,ACRIVT,ACRIVPAY,ACRSSTX,ACRIVTX,^TMP("ACRRR",$J)
- Q
- SELECT ;
- K ACRFINAL
- B11 S DIR(0)="LO^1:"_ACRSSNO
- S DIR("A")="Edit which item(s)"
- W !
- D DIR^ACRFDIC
- I $D(ACROUT) K ACRFINAL Q
- I 'Y D Q
- .S ACRFINAL=0
- .S ACRXX=0
- .F S ACRXX=$O(^TMP("ACRRR",$J,ACRXX)) Q:'ACRXX I $D(^TMP("ACRRR",$J,ACRXX)) S Y=ACRXX D BYRR1
- .S ACRQUIT=""
- N ACRXX
- S ACRXX=Y
- F ACRI=1:1 S Y=$P(ACRXX,",",ACRI) Q:'Y D:$D(^TMP("ACRRR",$J,Y)) BYRR1 Q:$D(ACROUT)
- K ACRQUIT,ACRFINAL
- Q
- BYRR1 S (ACRRRDA,DA)=+^TMP("ACRRR",$J,Y)
- S DIE="^ACRRR("
- S DR="[ACR INVOICE AUDIT]"
- I '$D(ACRFINAL) D
- .W !!?22,"Item number ",Y
- .D DIE^ACRFDIC
- S ACRSSDA=+^ACRRR(ACRRRDA,0)
- D SYNC^ACRFRR32
- Q
- RR ;EP;SELECT RECEIVING REPORTS FOR AUDITING
- K ACRRRNO,ACRRRNOX
- D RRNO^ACRFRR31
- Q
- GATHER ;EP;GATHER INFO ON RECEIVING ACTIONS
- K ACRSST,ACRSSTX,ACRIVTX,ACRRR,ACRIVT
- N I,J,K,X,Y,Z
- I $G(ACRRRNOX),$G(ACRDOCDA) F J=1:1 S X=$P(ACRRRNOX,",",J) Q:X="" D
- .K ACRIVPAY
- .S Y=0
- .F S Y=$O(^ACRRR("AC",ACRDOCDA,X,Y)) Q:'Y D
- ..S Z=0
- ..F S Z=$O(^ACRRR("AC",ACRDOCDA,X,Y,Z)) Q:'Z D G1
- S ACRSSTX=$G(ACRSST)
- S ACRIVTX=$G(ACRIVT)
- K ACRQUIT
- Q
- G1 S ACR0=$G(^ACRRR(Z,0))
- S ACRDT=$G(^ACRRR(Z,"DT"))
- S:'$P(ACRDT,U,5) $P(ACRDT,U,5)=$P(ACRDT,U),$P(^ACRRR(Z,"DT"),U,5)=$P(ACRDT,U)
- Q:'$P(ACRDT,U,3)
- S I=$G(I)+1
- S $P(^TMP("ACRRR",$J,I),U)=Z
- S $P(^TMP("ACRRR",$J,I),U,2)=+ACRDT
- S $P(^TMP("ACRRR",$J,I),U,3)=$P(^TMP("ACRRR",$J,I),U,3)+$P(ACRDT,U,3)
- S $P(^TMP("ACRRR",$J,I),U,4)=$P(ACR0,U,2)
- S $P(^TMP("ACRRR",$J,I),U,5)=$P(ACRDT,U,5)
- S $P(^TMP("ACRRR",$J,I),U,6)=$P(ACRDT,U,6)
- S ACRXX=I
- D D1
- Q
- DISPLAY ;DISPLAY ITEMS FOR AUDIT
- K ACRSST,ACRIVT,ACRIVPAY,ACRXX
- D HEAD
- K ACRJ
- S (ACRXX,ACRJ)=0
- F S ACRXX=$O(^TMP("ACRRR",$J,ACRXX)) Q:'ACRXX!$D(ACRQUIT) S ACRJ=ACRJ+1
- S ACRMAX=ACRJ
- S (ACRXX,ACRJ)=0
- F S ACRXX=$O(^TMP("ACRRR",$J,ACRXX)) Q:'ACRXX!$D(ACRQUIT) D DISP
- K ACRQUIT
- I '$G(ACRMAX) W !,"NO ITEMS ON FILE FOR THIS RECEIVING REPORT." D PAUSE^ACRFWARN S ACRQUIT="" Q
- W !?22,"Totals:"
- W ?41,"-------------"
- W ?55,"-------------"
- W !?41,$J($FN(ACRSSTX,"P",2),13)
- W ?55,$J($FN(ACRIVTX,"P",2),13)
- W:ACRIVTX>0 ?69,$J($P(ACRIVTX-ACRSSTX,"."),4)
- W:ACRSSTX>0 !?69,$J($P((ACRIVTX/ACRSSTX)*100-100,"."),4)
- S (ACRSSMAX,ACRSSNO)=ACRMAX
- Q
- DISP S ACRJ=ACRJ+1
- D D1
- W !,$J(ACRJ,3)
- I $P(ACRSSNMS,U)]"" D
- .W ?4,"VON: ",$P(ACRSSNMS,U)
- .W !?3
- I $P(ACRSSNMS,U,3)]"" D
- .W ?4,"NDC: ",$P(ACRSSNMS,U,3)
- .W !?3
- I $P(ACRSSNMS,U,2)]"" D
- .W ?4,"NSN: ",$P(ACRSSNMS,U,2)
- .W !?3
- W ?4,$P(ACRSSDSC,U)
- N ACRJ,ACRI,ACRX
- F ACRJ=2:1:5 I $P(ACRSSDSC,U,ACRJ)]"" S ACRX=$P(ACRSSDSC,U,ACRJ) D
- .F ACRI=1:1 S ACRY=$P(ACRX," ",ACRI) Q:ACRY="" D
- .W:$X+$L(ACRY)>79 !?3
- .W ?$X+1,ACRY
- W:ACRNOTES]"" !
- F ACRJ=1:1:5 I $P(ACRNOTES,U,ACRJ)]"" S ACRX=$P(ACRNOTES,U,ACRJ) D
- .F ACRI=1:1 S ACRY=$P(ACRX," ",ACRI) Q:ACRY="" D
- .W:$X+$L(ACRY)>79 !?3
- .W ?$X+1,ACRY
- K ACRSSDSC,ACRNOTES
- W !?22,$J(ACRSSACP,6)
- W ?29,$J($FN(ACRSSUP,"P",2),12)
- W ?41,$J($FN(ACRSSIT,"P",2),13)
- W:ACRIVIT>0 ?69,$J($P(ACRIVIT-ACRSSIT,"."),4)
- I ACRIVACP]"" D
- .W !?13,"INVOICED:"
- .W ?22,$J(ACRIVACP,6)
- .W ?29,$J($FN(ACRIVUP,"P",2),12)
- .W ?55,$J($FN(ACRIVIT,"P",2),13)
- .I $P(^TMP("ACRRR",$J,ACRXX),U,10)="PAID" W !?13,"(PAYMENT MADE FOR THIS ITEM.)"
- I ACRIVIT,ACRSSIT>0 W ?69,$J($P((ACRIVIT/ACRSSIT)*100-100,"."),4)
- I IOSL-4<$Y D
- .S DIR(0)="YO"
- .S DIR("A")="Display Remaining Items"
- .S DIR("B")="YES"
- .W !
- .D DIR^ACRFDIC
- .I Y'=1 S ACRQUIT="" Q
- .D HEAD
- Q
- HEAD W @IOF
- W !?10,@ACRON,"SERVICES/SUPPLIES",@ACROF," RECEIVED FOR"
- W !?10,"PURCHASE ORDER NO..: ",@ACRON,$P(ACRDOC0,U,2),@ACROF
- W !?10,"RECEIVING REPORT(S): ",@ACRON,$E(ACRRRNOX,1,$L(ACRRRNOX)-1),@ACROF
- W !?69,"VARI"
- W !?22,"ACC-"
- W ?41,"OBLIGATED"
- W ?55,"RECOMMENDED"
- W ?69,"ANCE"
- W !,"ITM"
- W ?4,"ORDER #/DESCRIPT"
- W ?22,"EPTED"
- W ?29,"UNIT PRICE"
- W ?41,"AMOUNT"
- W ?55,"PAYMENT"
- W ?69,"$$/%"
- W !,"---"
- W ?4,"-----------------"
- W ?22,"------"
- W ?29,"-----------"
- W ?41,"-------------"
- W ?55,"-------------"
- W ?69,"----"
- Q
- D1 K ACRSSDT,ACRSSNMS,ACRSSDSC,ACRNOTES,ACRSSUP,ACRSSACP,ACRSSACT,ACRIVACP,ACRSSIT,ACRIVIT
- S ACRRRDA=+^TMP("ACRRR",$J,ACRXX)
- I 'ACRRRDA S ACRJ=ACRJ-1 Q
- S ACRSSDA=+^ACRRR(ACRRRDA,0)
- I '$D(^ACRSS(+ACRSSDA,0)) S ACRJ=ACRJ-1 Q
- S ACRSS0=^ACRSS(ACRSSDA,0)
- S ACRSSDT=^ACRSS(ACRSSDA,"DT")
- I $P(^ACRRR(ACRRRDA,"DT"),U)=""!($P(^("DT"),U,5)="") D
- .N X,Y,Z
- .S DA=ACRRRDA
- .S DIE="^ACRRR("
- .S DR="1////"_$P(ACRSSDT,U,3)
- .D DIE^ACRFDIC
- S ACROBJDA=$P(ACRSS0,U,4)
- S ACRCANDA=$P(ACRSS0,U,5)
- S ACRSSNMS=$G(^ACRSS(ACRSSDA,"NMS"))
- S ACRSSDSC=$G(^ACRSS(ACRSSDA,"DESC"))
- S ACRNOTES=$G(^ACRSS(ACRSSDA,"NOTES"))
- S ACRSSUP=$P(ACRSSDT,U,3)
- S ACRSSACP=$P(^TMP("ACRRR",$J,ACRXX),U,3)
- S ACRSSACT=$G(ACRSSACT)+ACRSSACP
- S ACRIVACP=$P(^TMP("ACRRR",$J,ACRXX),U,6)
- S ACRIVACT=$G(ACRIVACT)+ACRIVACP
- S ACRIVUP=$P(^TMP("ACRRR",$J,ACRXX),U,5)
- S:ACRIVUP="" ACRIVUP=ACRSSUP
- S ACRSSIT=ACRSSACP*ACRSSUP
- S:ACRIVACP]""&(ACRIVUP]"") ACRIVIT=ACRIVACP*ACRIVUP
- S:$G(ACRIVIT)="" ACRIVIT=ACRSSIT
- I $P(ACR0,U,11)>0,ACRSSACP=ACRIVACP D
- .S $P(^TMP("ACRRR",$J,ACRXX),U,10)="PAID"
- .S ACRIVIT=0
- S ACRIVPAY(ACRCANDA,ACROBJDA)=$G(ACRIVPAY(ACRCANDA,ACROBJDA))+ACRIVIT
- S ACRSST=$G(ACRSST)+ACRSSIT
- S ACRIVT=$G(ACRIVT)+ACRIVIT
- Q
- ACRFIV ;IHS/OIRM/DSD/THL,AEF - INVOICE AUDIT; [ 11/01/2001 9:44 AM ]
- +1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
- +2 ;;ROUTINE CALLED DURING PROCESSING OF INVOICES
- EN KILL ACRSST,ACRIVT,ACRSSTX,ACRIVTX,ACRIVPAY,^TMP("ACRRR",$JOB)
- +1 IF '+$GET(ACRRRNOX)
- QUIT
- +2 IF 'ACRVDA
- QUIT
- +3 DO GATHER
- +4 DO DISPLAY
- +5 IF '$DATA(ACRQUIT)
- DO SELECT
- EXIT KILL ACRSSDT,ACRSSNMS,ACRSSDSC,ACRNOTES,ACRSSUP,ACRSSACP,ACRSSACT,ACRIVACP,ACRSSIT,ACRIVIT,ACRSST,ACRIVT,ACRIVPAY,ACRSSTX,ACRIVTX,^TMP("ACRRR",$JOB)
- +1 QUIT
- SELECT ;
- +1 KILL ACRFINAL
- B11 SET DIR(0)="LO^1:"_ACRSSNO
- +1 SET DIR("A")="Edit which item(s)"
- +2 WRITE !
- +3 DO DIR^ACRFDIC
- +4 IF $DATA(ACROUT)
- KILL ACRFINAL
- QUIT
- +5 IF 'Y
- Begin DoDot:1
- +6 SET ACRFINAL=0
- +7 SET ACRXX=0
- +8 FOR
- SET ACRXX=$ORDER(^TMP("ACRRR",$JOB,ACRXX))
- IF 'ACRXX
- QUIT
- IF $DATA(^TMP("ACRRR",$JOB,ACRXX))
- SET Y=ACRXX
- DO BYRR1
- +9 SET ACRQUIT=""
- End DoDot:1
- QUIT
- +10 NEW ACRXX
- +11 SET ACRXX=Y
- +12 FOR ACRI=1:1
- SET Y=$PIECE(ACRXX,",",ACRI)
- IF 'Y
- QUIT
- IF $DATA(^TMP("ACRRR",$JOB,Y))
- DO BYRR1
- IF $DATA(ACROUT)
- QUIT
- +13 KILL ACRQUIT,ACRFINAL
- +14 QUIT
- BYRR1 SET (ACRRRDA,DA)=+^TMP("ACRRR",$JOB,Y)
- +1 SET DIE="^ACRRR("
- +2 SET DR="[ACR INVOICE AUDIT]"
- +3 IF '$DATA(ACRFINAL)
- Begin DoDot:1
- +4 WRITE !!?22,"Item number ",Y
- +5 DO DIE^ACRFDIC
- End DoDot:1
- +6 SET ACRSSDA=+^ACRRR(ACRRRDA,0)
- +7 DO SYNC^ACRFRR32
- +8 QUIT
- RR ;EP;SELECT RECEIVING REPORTS FOR AUDITING
- +1 KILL ACRRRNO,ACRRRNOX
- +2 DO RRNO^ACRFRR31
- +3 QUIT
- GATHER ;EP;GATHER INFO ON RECEIVING ACTIONS
- +1 KILL ACRSST,ACRSSTX,ACRIVTX,ACRRR,ACRIVT
- +2 NEW I,J,K,X,Y,Z
- +3 IF $GET(ACRRRNOX)
- IF $GET(ACRDOCDA)
- FOR J=1:1
- SET X=$PIECE(ACRRRNOX,",",J)
- IF X=""
- QUIT
- Begin DoDot:1
- +4 KILL ACRIVPAY
- +5 SET Y=0
- +6 FOR
- SET Y=$ORDER(^ACRRR("AC",ACRDOCDA,X,Y))
- IF 'Y
- QUIT
- Begin DoDot:2
- +7 SET Z=0
- +8 FOR
- SET Z=$ORDER(^ACRRR("AC",ACRDOCDA,X,Y,Z))
- IF 'Z
- QUIT
- DO G1
- End DoDot:2
- End DoDot:1
- +9 SET ACRSSTX=$GET(ACRSST)
- +10 SET ACRIVTX=$GET(ACRIVT)
- +11 KILL ACRQUIT
- +12 QUIT
- G1 SET ACR0=$GET(^ACRRR(Z,0))
- +1 SET ACRDT=$GET(^ACRRR(Z,"DT"))
- +2 IF '$PIECE(ACRDT,U,5)
- SET $PIECE(ACRDT,U,5)=$PIECE(ACRDT,U)
- SET $PIECE(^ACRRR(Z,"DT"),U,5)=$PIECE(ACRDT,U)
- +3 IF '$PIECE(ACRDT,U,3)
- QUIT
- +4 SET I=$GET(I)+1
- +5 SET $PIECE(^TMP("ACRRR",$JOB,I),U)=Z
- +6 SET $PIECE(^TMP("ACRRR",$JOB,I),U,2)=+ACRDT
- +7 SET $PIECE(^TMP("ACRRR",$JOB,I),U,3)=$PIECE(^TMP("ACRRR",$JOB,I),U,3)+$PIECE(ACRDT,U,3)
- +8 SET $PIECE(^TMP("ACRRR",$JOB,I),U,4)=$PIECE(ACR0,U,2)
- +9 SET $PIECE(^TMP("ACRRR",$JOB,I),U,5)=$PIECE(ACRDT,U,5)
- +10 SET $PIECE(^TMP("ACRRR",$JOB,I),U,6)=$PIECE(ACRDT,U,6)
- +11 SET ACRXX=I
- +12 DO D1
- +13 QUIT
- DISPLAY ;DISPLAY ITEMS FOR AUDIT
- +1 KILL ACRSST,ACRIVT,ACRIVPAY,ACRXX
- +2 DO HEAD
- +3 KILL ACRJ
- +4 SET (ACRXX,ACRJ)=0
- +5 FOR
- SET ACRXX=$ORDER(^TMP("ACRRR",$JOB,ACRXX))
- IF 'ACRXX!$DATA(ACRQUIT)
- QUIT
- SET ACRJ=ACRJ+1
- +6 SET ACRMAX=ACRJ
- +7 SET (ACRXX,ACRJ)=0
- +8 FOR
- SET ACRXX=$ORDER(^TMP("ACRRR",$JOB,ACRXX))
- IF 'ACRXX!$DATA(ACRQUIT)
- QUIT
- DO DISP
- +9 KILL ACRQUIT
- +10 IF '$GET(ACRMAX)
- WRITE !,"NO ITEMS ON FILE FOR THIS RECEIVING REPORT."
- DO PAUSE^ACRFWARN
- SET ACRQUIT=""
- QUIT
- +11 WRITE !?22,"Totals:"
- +12 WRITE ?41,"-------------"
- +13 WRITE ?55,"-------------"
- +14 WRITE !?41,$JUSTIFY($FNUMBER(ACRSSTX,"P",2),13)
- +15 WRITE ?55,$JUSTIFY($FNUMBER(ACRIVTX,"P",2),13)
- +16 IF ACRIVTX>0
- WRITE ?69,$JUSTIFY($PIECE(ACRIVTX-ACRSSTX,"."),4)
- +17 IF ACRSSTX>0
- WRITE !?69,$JUSTIFY($PIECE((ACRIVTX/ACRSSTX)*100-100,"."),4)
- +18 SET (ACRSSMAX,ACRSSNO)=ACRMAX
- +19 QUIT
- DISP SET ACRJ=ACRJ+1
- +1 DO D1
- +2 WRITE !,$JUSTIFY(ACRJ,3)
- +3 IF $PIECE(ACRSSNMS,U)]""
- Begin DoDot:1
- +4 WRITE ?4,"VON: ",$PIECE(ACRSSNMS,U)
- +5 WRITE !?3
- End DoDot:1
- +6 IF $PIECE(ACRSSNMS,U,3)]""
- Begin DoDot:1
- +7 WRITE ?4,"NDC: ",$PIECE(ACRSSNMS,U,3)
- +8 WRITE !?3
- End DoDot:1
- +9 IF $PIECE(ACRSSNMS,U,2)]""
- Begin DoDot:1
- +10 WRITE ?4,"NSN: ",$PIECE(ACRSSNMS,U,2)
- +11 WRITE !?3
- End DoDot:1
- +12 WRITE ?4,$PIECE(ACRSSDSC,U)
- +13 NEW ACRJ,ACRI,ACRX
- +14 FOR ACRJ=2:1:5
- IF $PIECE(ACRSSDSC,U,ACRJ)]""
- SET ACRX=$PIECE(ACRSSDSC,U,ACRJ)
- Begin DoDot:1
- +15 FOR ACRI=1:1
- SET ACRY=$PIECE(ACRX," ",ACRI)
- IF ACRY=""
- QUIT
- Begin DoDot:2
- End DoDot:2
- +16 IF $X+$LENGTH(ACRY)>79
- WRITE !?3
- +17 WRITE ?$X+1,ACRY
- End DoDot:1
- +18 IF ACRNOTES]""
- WRITE !
- +19 FOR ACRJ=1:1:5
- IF $PIECE(ACRNOTES,U,ACRJ)]""
- SET ACRX=$PIECE(ACRNOTES,U,ACRJ)
- Begin DoDot:1
- +20 FOR ACRI=1:1
- SET ACRY=$PIECE(ACRX," ",ACRI)
- IF ACRY=""
- QUIT
- Begin DoDot:2
- End DoDot:2
- +21 IF $X+$LENGTH(ACRY)>79
- WRITE !?3
- +22 WRITE ?$X+1,ACRY
- End DoDot:1
- +23 KILL ACRSSDSC,ACRNOTES
- +24 WRITE !?22,$JUSTIFY(ACRSSACP,6)
- +25 WRITE ?29,$JUSTIFY($FNUMBER(ACRSSUP,"P",2),12)
- +26 WRITE ?41,$JUSTIFY($FNUMBER(ACRSSIT,"P",2),13)
- +27 IF ACRIVIT>0
- WRITE ?69,$JUSTIFY($PIECE(ACRIVIT-ACRSSIT,"."),4)
- +28 IF ACRIVACP]""
- Begin DoDot:1
- +29 WRITE !?13,"INVOICED:"
- +30 WRITE ?22,$JUSTIFY(ACRIVACP,6)
- +31 WRITE ?29,$JUSTIFY($FNUMBER(ACRIVUP,"P",2),12)
- +32 WRITE ?55,$JUSTIFY($FNUMBER(ACRIVIT,"P",2),13)
- +33 IF $PIECE(^TMP("ACRRR",$JOB,ACRXX),U,10)="PAID"
- WRITE !?13,"(PAYMENT MADE FOR THIS ITEM.)"
- End DoDot:1
- +34 IF ACRIVIT
- IF ACRSSIT>0
- WRITE ?69,$JUSTIFY($PIECE((ACRIVIT/ACRSSIT)*100-100,"."),4)
- +35 IF IOSL-4<$Y
- Begin DoDot:1
- +36 SET DIR(0)="YO"
- +37 SET DIR("A")="Display Remaining Items"
- +38 SET DIR("B")="YES"
- +39 WRITE !
- +40 DO DIR^ACRFDIC
- +41 IF Y'=1
- SET ACRQUIT=""
- QUIT
- +42 DO HEAD
- End DoDot:1
- +43 QUIT
- HEAD WRITE @IOF
- +1 WRITE !?10,@ACRON,"SERVICES/SUPPLIES",@ACROF," RECEIVED FOR"
- +2 WRITE !?10,"PURCHASE ORDER NO..: ",@ACRON,$PIECE(ACRDOC0,U,2),@ACROF
- +3 WRITE !?10,"RECEIVING REPORT(S): ",@ACRON,$EXTRACT(ACRRRNOX,1,$LENGTH(ACRRRNOX)-1),@ACROF
- +4 WRITE !?69,"VARI"
- +5 WRITE !?22,"ACC-"
- +6 WRITE ?41,"OBLIGATED"
- +7 WRITE ?55,"RECOMMENDED"
- +8 WRITE ?69,"ANCE"
- +9 WRITE !,"ITM"
- +10 WRITE ?4,"ORDER #/DESCRIPT"
- +11 WRITE ?22,"EPTED"
- +12 WRITE ?29,"UNIT PRICE"
- +13 WRITE ?41,"AMOUNT"
- +14 WRITE ?55,"PAYMENT"
- +15 WRITE ?69,"$$/%"
- +16 WRITE !,"---"
- +17 WRITE ?4,"-----------------"
- +18 WRITE ?22,"------"
- +19 WRITE ?29,"-----------"
- +20 WRITE ?41,"-------------"
- +21 WRITE ?55,"-------------"
- +22 WRITE ?69,"----"
- +23 QUIT
- D1 KILL ACRSSDT,ACRSSNMS,ACRSSDSC,ACRNOTES,ACRSSUP,ACRSSACP,ACRSSACT,ACRIVACP,ACRSSIT,ACRIVIT
- +1 SET ACRRRDA=+^TMP("ACRRR",$JOB,ACRXX)
- +2 IF 'ACRRRDA
- SET ACRJ=ACRJ-1
- QUIT
- +3 SET ACRSSDA=+^ACRRR(ACRRRDA,0)
- +4 IF '$DATA(^ACRSS(+ACRSSDA,0))
- SET ACRJ=ACRJ-1
- QUIT
- +5 SET ACRSS0=^ACRSS(ACRSSDA,0)
- +6 SET ACRSSDT=^ACRSS(ACRSSDA,"DT")
- +7 IF $PIECE(^ACRRR(ACRRRDA,"DT"),U)=""!($PIECE(^("DT"),U,5)="")
- Begin DoDot:1
- +8 NEW X,Y,Z
- +9 SET DA=ACRRRDA
- +10 SET DIE="^ACRRR("
- +11 SET DR="1////"_$PIECE(ACRSSDT,U,3)
- +12 DO DIE^ACRFDIC
- End DoDot:1
- +13 SET ACROBJDA=$PIECE(ACRSS0,U,4)
- +14 SET ACRCANDA=$PIECE(ACRSS0,U,5)
- +15 SET ACRSSNMS=$GET(^ACRSS(ACRSSDA,"NMS"))
- +16 SET ACRSSDSC=$GET(^ACRSS(ACRSSDA,"DESC"))
- +17 SET ACRNOTES=$GET(^ACRSS(ACRSSDA,"NOTES"))
- +18 SET ACRSSUP=$PIECE(ACRSSDT,U,3)
- +19 SET ACRSSACP=$PIECE(^TMP("ACRRR",$JOB,ACRXX),U,3)
- +20 SET ACRSSACT=$GET(ACRSSACT)+ACRSSACP
- +21 SET ACRIVACP=$PIECE(^TMP("ACRRR",$JOB,ACRXX),U,6)
- +22 SET ACRIVACT=$GET(ACRIVACT)+ACRIVACP
- +23 SET ACRIVUP=$PIECE(^TMP("ACRRR",$JOB,ACRXX),U,5)
- +24 IF ACRIVUP=""
- SET ACRIVUP=ACRSSUP
- +25 SET ACRSSIT=ACRSSACP*ACRSSUP
- +26 IF ACRIVACP]""&(ACRIVUP]"")
- SET ACRIVIT=ACRIVACP*ACRIVUP
- +27 IF $GET(ACRIVIT)=""
- SET ACRIVIT=ACRSSIT
- +28 IF $PIECE(ACR0,U,11)>0
- IF ACRSSACP=ACRIVACP
- Begin DoDot:1
- +29 SET $PIECE(^TMP("ACRRR",$JOB,ACRXX),U,10)="PAID"
- +30 SET ACRIVIT=0
- End DoDot:1
- +31 SET ACRIVPAY(ACRCANDA,ACROBJDA)=$GET(ACRIVPAY(ACRCANDA,ACROBJDA))+ACRIVIT
- +32 SET ACRSST=$GET(ACRSST)+ACRSSIT
- +33 SET ACRIVT=$GET(ACRIVT)+ACRIVIT
- +34 QUIT
