- RMPR4C1 ;PHX/HNB,RVD - PURCHASE CARD SUMMARY SHEET ;3/1/1996
- ;;3.0;PROSTHETICS;**3,20,26**;Feb 09, 1996
- ;using new data fields
- W !,"Prosthetics Purchase Card Summary Sheet"
- W !!
- START K ^TMP($J) D DIV4^RMPRSIT G:$D(X) EX S RMPRCOUN=0 D HOME^%ZIS W !! S %DT("A")="Starting Date: ",%DT="AEPX" D ^%DT S RMPRBDT=Y G:Y<0 EX
- S %DT("A")="Ending Date: ",%DT="AEX" D ^%DT G:Y<0 EX I RMPRBDT>Y W !,$C(7),"Invalid Date Range Selection!!" G START
- S RMPREDT=Y,Y=RMPRBDT D DD^%DT S RMPRX=Y,Y=RMPREDT D DD^%DT S RMPRY=Y
- PCRD ;ask purchase card number
- K DIR S DIR(0)="FO",DIR("A")="Enter PURCHASE CARD NUMBER"
- S DIR("?")="Enter the 16 Digit Purchase Card Number"
- D ^DIR K DIR
- I $D(DTOUT)!($D(DUOUT)) W !,$C(7),$C(7),"Try Later!" G EX
- I $L(X)>16!($L(X)<16)!(X'?.N) W !,"Must be 16 a Digit Number." G PCRD
- S RMPRPCRD=Y
- ;task it
- S %ZIS="MQ" K IOP D ^%ZIS G:POP EX
- I '$D(IO("Q")) U IO G PRINT
- S ZTDESC="PURCHASE CARD SUMMARY",ZTRTN="PRINT^RMPR4C1"
- S ZTSAVE("RMPRBDT")="",ZTSAVE("RMPREDT")="",ZTSAVE("RMPRX")=""
- S ZTSAVE("RMPRY")="",ZTSAVE("RMPR(")="",ZTSAVE("RMPRPCRD")=""
- D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED!" H 1 G EX
- PRINT S X1=RMPRBDT,X2=-1 D C^%DTC S RO=X,RP=0,PAGE=1,RMPRCOUN=0,RMPREND=""
- I $E(IOST)["C" D WAIT^DICD W @IOF
- F S RO=$O(^RMPR(664,"B",RO)) Q:RO'>0 Q:RO>RMPREDT F S RP=$O(^RMPR(664,"B",RO,RP)) Q:RP'>0 D CK
- ;TCLCNT, total closed liquidated amount
- ;CNT, total authorized amount
- ;ORCNT1, total open transactions
- ;ORCNT2, total closed transactions
- S (RP,RMPROBL,CNT,TCLCNT,NL,RMAMTOT)=""
- S (ORCNT1,ORCNT2)=0
- F S RMPROBL=$O(^TMP($J,RMPROBL)) Q:RMPROBL'>0 Q:RMPREND=1 F S RP=$O(^TMP($J,RMPROBL,RP)) Q:RP'>0 S RMAST=$G(^(RP)) Q:RMPREND=1 D WRI
- I $D(RMPREDT)&(RMPRCOUN=0) W @IOF D HDR W $C(7),!!,"NO SELECTIONS MADE DURING THIS DATE RANGE!!"
- I $D(RMPREDT),RMPRCOUN>0,RMPREND'=1 D
- .W !,RMPR("L"),!,?26,"TOTALS"
- .W ?36,$J(NL,9,2)
- .W ?48,$J(RMAMTOT,7,2)
- .W ?57,$J(TCLCNT,9,2)
- .W ?69,$J(CNT,9,2)
- .W !!,?10," Total liquidated ",$J(TCLCNT,9,2)
- .W !,?10," Total non-liquidated ",$J(CNT-TCLCNT,9,2)
- .W !,?10,"Total Cumulative Authorized ",$J(CNT,9,2)
- .W !!,?10,"Total Open Orders/Transactions ",$J(ORCNT1,5)
- .W !,?8,"Total Closed Orders/Transactions ",$J(ORCNT2,5)
- .H 1
- EXIT I $E(IOST)["C"&($Y<20) F W ! Q:$Y>20
- I $D(RMPREDT),'$D(DTOUT),'$D(DUOUT),$E(IOST)["C",'$D(RMPRFLL),RMPREND'=1 S DIR(0)="E" D ^DIR
- EX K RMPREND,RMPROBL,RMPRFLL,RMPRFLG,DUOUT,DIR,RO,RP,RMPRY,RMPRCOUN,RMPRX,RMPRBDT,RMPREDT,RMPRCK,%DT,X,Y,PAGE,IT,ZTSK,^TMP($J) D ^%ZISC
- K CNT,DTOUT,ROBL,X1,X2,RMPR,RMSHI,R660T,R660AC,RMAMTOT,RMAST,RMCUM,RMIDA,RMAMEN,CLODT,TCLCNT,NL,ORCNT1,ORCNT2,%ZIS,DCT,RMACS
- Q
- CK ;check record, apply screen
- Q:'$D(^RMPR(664,RP,0))
- ;vendor, purchase card, cancelation date
- Q:$P(^RMPR(664,RP,0),U,4)=""!($P($G(^(4)),U,1)="")!($P(^(0),U,5)'="")
- Q:$P(^RMPR(664,RP,0),U,14)'=""&($P(^(0),U,14)'=RMPR("STA"))
- S ROBL=$P($G(^RMPR(664,RP,4)),U,1)
- S RMPROBL=$$DEC^RMPR4LI($P(^RMPR(664,RP,4),U,1),$P(^RMPR(664,RP,0),U,9),RP)
- Q:RMPROBL'=RMPRPCRD
- S RMAST="",(R660AC,R660T,RMACS)=0,DCT=0 S RMACS=$S($P(^RMPR(664,RP,0),U,11):$P(^RMPR(664,RP,0),U,11),1:$P(^RMPR(664,RP,0),U,10)) S RMSHI=$P(^RMPR(664,RP,0),U,12) I RMSHI S R660T=$P($G(^RMPR(660,RMSHI,0)),U,17) S:+RMACS'=+R660T RMAST="*"
- I $D(^RMPR(664,RP,2)),$P(^(2),U,6) S DCT=$P(^(2),U,6),DCT=DCT/100
- F I=0:0 S I=$O(^RMPR(664,RP,1,I)) Q:I'>0 S R660T=$S($P($G(^(I,0)),U,7):$P(^(0),U,7)*$P(^(0),U,4),1:$P(^(0),U,3)*$P(^(0),U,4)) I R660T D
- .S:DCT R660T=R660T-(R660T*DCT)
- .S RMIDA=$P($G(^(0)),U,13) I RMIDA S R660AC=$P($G(^RMPR(660,RMIDA,0)),U,16) S:+R660AC'=+R660T RMAST="*"
- S ^TMP($J,RMPROBL,RP)=RMAST,RMPRCOUN=RMPRCOUN+1
- Q
- WRI I '$D(RMPRFLG) D HDR
- W !,$E($P(^DPT($P(^RMPR(664,RP,0),U,2),0),U,1),1,12)
- W ?14,$E($P(^DPT($P(^RMPR(664,RP,0),U,2),0),U,9),6,9)
- N RD
- S RD=$P(^RMPR(664,RP,0),U,1)
- S RD=$P(RD,"."),RD=$E(RD,4,5)_"/"_$E(RD,6,7)
- W ?19,RD,?26,$P($G(^RMPR(664,RP,4)),U,5)
- S (AACNT,CLCNT,RMAMEN)=0
- ;AACNT, est amount
- ;RMAMEN, ADJ amount
- ;CLCNT, closed amount
- ;CLODT, CLOSE OUT DATE
- S RMAMEN=$P(^RMPR(664,RP,2),U,9)
- S AACNT=$P(^RMPR(664,RP,4),U,3)
- S CLCNT=$P(^RMPR(664,RP,4),U,4)
- S CLODT=$P(^RMPR(664,RP,0),U,8)
- I 'RMAMEN S RMAMEN=0
- E S RMAMEN=RMAMEN-AACNT
- I $G(CLODT) S ORCNT2=ORCNT2+1
- E S ORCNT1=ORCNT1+1
- S NL=NL+AACNT,RMAMTOT=RMAMTOT+RMAMEN
- S TCLCNT=TCLCNT+CLCNT
- S RMCUM=$S(CLCNT'="":CLCNT,AACNT'="":AACNT+RMAMEN,1:"")
- ;S:RMCUM'=R660T RMAST="*"
- S CNT=CNT+RMCUM
- W ?36,$J(AACNT,9,2)
- W ?48,$J(RMAMEN,7,2)
- W ?57,$J(CLCNT,9,2)
- W ?69,$J(CNT,9,2)_RMAST
- S RMPRFLG=1
- I $E(IOST)["C"&($Y>(IOSL-6)) W ! S DIR(0)="E" D ^DIR S:Y<1 RMPREND=1 Q:Y="" S:Y<1 RMPRFLL=1 Q:Y<1 S:$D(DTOUT) RMPREND=1 Q:$D(DTOUT) D HDR Q
- I $Y>(IOSL-6) K RMPRFLG
- Q
- HDR I PAGE'=1 W @IOF
- W !,RMPRX_"-",RMPRY," "_RMPRPCRD_" Summary "_"STA "_$$STA^RMPRUTIL,?72,"PAGE ",PAGE,! S PAGE=PAGE+1
- W !,"Patient",?14,"SSN",?19,"Date",?26,"PC #",?37,"Auth Amt",?48,"Adj Amt",?59,"Liq Amt",?71,"Cum Amt",!,RMPR("L")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR4C1 5039 printed Feb 18, 2025@23:59:09 Page 2
- RMPR4C1 ;PHX/HNB,RVD - PURCHASE CARD SUMMARY SHEET ;3/1/1996
- +1 ;;3.0;PROSTHETICS;**3,20,26**;Feb 09, 1996
- +2 ;using new data fields
- +3 WRITE !,"Prosthetics Purchase Card Summary Sheet"
- +4 WRITE !!
- START KILL ^TMP($JOB)
- DO DIV4^RMPRSIT
- if $DATA(X)
- GOTO EX
- SET RMPRCOUN=0
- DO HOME^%ZIS
- WRITE !!
- SET %DT("A")="Starting Date: "
- SET %DT="AEPX"
- DO ^%DT
- SET RMPRBDT=Y
- if Y<0
- GOTO EX
- +1 SET %DT("A")="Ending Date: "
- SET %DT="AEX"
- DO ^%DT
- if Y<0
- GOTO EX
- IF RMPRBDT>Y
- WRITE !,$CHAR(7),"Invalid Date Range Selection!!"
- GOTO START
- +2 SET RMPREDT=Y
- SET Y=RMPRBDT
- DO DD^%DT
- SET RMPRX=Y
- SET Y=RMPREDT
- DO DD^%DT
- SET RMPRY=Y
- PCRD ;ask purchase card number
- +1 KILL DIR
- SET DIR(0)="FO"
- SET DIR("A")="Enter PURCHASE CARD NUMBER"
- +2 SET DIR("?")="Enter the 16 Digit Purchase Card Number"
- +3 DO ^DIR
- KILL DIR
- +4 IF $DATA(DTOUT)!($DATA(DUOUT))
- WRITE !,$CHAR(7),$CHAR(7),"Try Later!"
- GOTO EX
- +5 IF $LENGTH(X)>16!($LENGTH(X)<16)!(X'?.N)
- WRITE !,"Must be 16 a Digit Number."
- GOTO PCRD
- +6 SET RMPRPCRD=Y
- +7 ;task it
- +8 SET %ZIS="MQ"
- KILL IOP
- DO ^%ZIS
- if POP
- GOTO EX
- +9 IF '$DATA(IO("Q"))
- USE IO
- GOTO PRINT
- +10 SET ZTDESC="PURCHASE CARD SUMMARY"
- SET ZTRTN="PRINT^RMPR4C1"
- +11 SET ZTSAVE("RMPRBDT")=""
- SET ZTSAVE("RMPREDT")=""
- SET ZTSAVE("RMPRX")=""
- +12 SET ZTSAVE("RMPRY")=""
- SET ZTSAVE("RMPR(")=""
- SET ZTSAVE("RMPRPCRD")=""
- +13 DO ^%ZTLOAD
- if $DATA(ZTSK)
- WRITE !,"REQUEST QUEUED!"
- HANG 1
- GOTO EX
- PRINT SET X1=RMPRBDT
- SET X2=-1
- DO C^%DTC
- SET RO=X
- SET RP=0
- SET PAGE=1
- SET RMPRCOUN=0
- SET RMPREND=""
- +1 IF $EXTRACT(IOST)["C"
- DO WAIT^DICD
- WRITE @IOF
- +2 FOR
- SET RO=$ORDER(^RMPR(664,"B",RO))
- if RO'>0
- QUIT
- if RO>RMPREDT
- QUIT
- FOR
- SET RP=$ORDER(^RMPR(664,"B",RO,RP))
- if RP'>0
- QUIT
- DO CK
- +3 ;TCLCNT, total closed liquidated amount
- +4 ;CNT, total authorized amount
- +5 ;ORCNT1, total open transactions
- +6 ;ORCNT2, total closed transactions
- +7 SET (RP,RMPROBL,CNT,TCLCNT,NL,RMAMTOT)=""
- +8 SET (ORCNT1,ORCNT2)=0
- +9 FOR
- SET RMPROBL=$ORDER(^TMP($JOB,RMPROBL))
- if RMPROBL'>0
- QUIT
- if RMPREND=1
- QUIT
- FOR
- SET RP=$ORDER(^TMP($JOB,RMPROBL,RP))
- if RP'>0
- QUIT
- SET RMAST=$GET(^(RP))
- if RMPREND=1
- QUIT
- DO WRI
- +10 IF $DATA(RMPREDT)&(RMPRCOUN=0)
- WRITE @IOF
- DO HDR
- WRITE $CHAR(7),!!,"NO SELECTIONS MADE DURING THIS DATE RANGE!!"
- +11 IF $DATA(RMPREDT)
- IF RMPRCOUN>0
- IF RMPREND'=1
- Begin DoDot:1
- +12 WRITE !,RMPR("L"),!,?26,"TOTALS"
- +13 WRITE ?36,$JUSTIFY(NL,9,2)
- +14 WRITE ?48,$JUSTIFY(RMAMTOT,7,2)
- +15 WRITE ?57,$JUSTIFY(TCLCNT,9,2)
- +16 WRITE ?69,$JUSTIFY(CNT,9,2)
- +17 WRITE !!,?10," Total liquidated ",$JUSTIFY(TCLCNT,9,2)
- +18 WRITE !,?10," Total non-liquidated ",$JUSTIFY(CNT-TCLCNT,9,2)
- +19 WRITE !,?10,"Total Cumulative Authorized ",$JUSTIFY(CNT,9,2)
- +20 WRITE !!,?10,"Total Open Orders/Transactions ",$JUSTIFY(ORCNT1,5)
- +21 WRITE !,?8,"Total Closed Orders/Transactions ",$JUSTIFY(ORCNT2,5)
- +22 HANG 1
- End DoDot:1
- EXIT IF $EXTRACT(IOST)["C"&($Y<20)
- FOR
- WRITE !
- if $Y>20
- QUIT
- +1 IF $DATA(RMPREDT)
- IF '$DATA(DTOUT)
- IF '$DATA(DUOUT)
- IF $EXTRACT(IOST)["C"
- IF '$DATA(RMPRFLL)
- IF RMPREND'=1
- SET DIR(0)="E"
- DO ^DIR
- EX KILL RMPREND,RMPROBL,RMPRFLL,RMPRFLG,DUOUT,DIR,RO,RP,RMPRY,RMPRCOUN,RMPRX,RMPRBDT,RMPREDT,RMPRCK,%DT,X,Y,PAGE,IT,ZTSK,^TMP($JOB)
- DO ^%ZISC
- +1 KILL CNT,DTOUT,ROBL,X1,X2,RMPR,RMSHI,R660T,R660AC,RMAMTOT,RMAST,RMCUM,RMIDA,RMAMEN,CLODT,TCLCNT,NL,ORCNT1,ORCNT2,%ZIS,DCT,RMACS
- +2 QUIT
- CK ;check record, apply screen
- +1 if '$DATA(^RMPR(664,RP,0))
- QUIT
- +2 ;vendor, purchase card, cancelation date
- +3 if $PIECE(^RMPR(664,RP,0),U,4)=""!($PIECE($GET(^(4)),U,1)="")!($PIECE(^(0),U,5)'="")
- QUIT
- +4 if $PIECE(^RMPR(664,RP,0),U,14)'=""&($PIECE(^(0),U,14)'=RMPR("STA"))
- QUIT
- +5 SET ROBL=$PIECE($GET(^RMPR(664,RP,4)),U,1)
- +6 SET RMPROBL=$$DEC^RMPR4LI($PIECE(^RMPR(664,RP,4),U,1),$PIECE(^RMPR(664,RP,0),U,9),RP)
- +7 if RMPROBL'=RMPRPCRD
- QUIT
- +8 SET RMAST=""
- SET (R660AC,R660T,RMACS)=0
- SET DCT=0
- SET RMACS=$SELECT($PIECE(^RMPR(664,RP,0),U,11):$PIECE(^RMPR(664,RP,0),U,11),1:$PIECE(^RMPR(664,RP,0),U,10))
- SET RMSHI=$PIECE(^RMPR(664,RP,0),U,12)
- IF RMSHI
- SET R660T=$PIECE($GET(^RMPR(660,RMSHI,0)),U,17)
- if +RMACS'=+R660T
- SET RMAST="*"
- +9 IF $DATA(^RMPR(664,RP,2))
- IF $PIECE(^(2),U,6)
- SET DCT=$PIECE(^(2),U,6)
- SET DCT=DCT/100
- +10 FOR I=0:0
- SET I=$ORDER(^RMPR(664,RP,1,I))
- if I'>0
- QUIT
- SET R660T=$SELECT($PIECE($GET(^(I,0)),U,7):$PIECE(^(0),U,7)*$PIECE(^(0),U,4),1:$PIECE(^(0),U,3)*$PIECE(^(0),U,4))
- IF R660T
- Begin DoDot:1
- +11 if DCT
- SET R660T=R660T-(R660T*DCT)
- +12 SET RMIDA=$PIECE($GET(^(0)),U,13)
- IF RMIDA
- SET R660AC=$PIECE($GET(^RMPR(660,RMIDA,0)),U,16)
- if +R660AC'=+R660T
- SET RMAST="*"
- End DoDot:1
- +13 SET ^TMP($JOB,RMPROBL,RP)=RMAST
- SET RMPRCOUN=RMPRCOUN+1
- +14 QUIT
- WRI IF '$DATA(RMPRFLG)
- DO HDR
- +1 WRITE !,$EXTRACT($PIECE(^DPT($PIECE(^RMPR(664,RP,0),U,2),0),U,1),1,12)
- +2 WRITE ?14,$EXTRACT($PIECE(^DPT($PIECE(^RMPR(664,RP,0),U,2),0),U,9),6,9)
- +3 NEW RD
- +4 SET RD=$PIECE(^RMPR(664,RP,0),U,1)
- +5 SET RD=$PIECE(RD,".")
- SET RD=$EXTRACT(RD,4,5)_"/"_$EXTRACT(RD,6,7)
- +6 WRITE ?19,RD,?26,$PIECE($GET(^RMPR(664,RP,4)),U,5)
- +7 SET (AACNT,CLCNT,RMAMEN)=0
- +8 ;AACNT, est amount
- +9 ;RMAMEN, ADJ amount
- +10 ;CLCNT, closed amount
- +11 ;CLODT, CLOSE OUT DATE
- +12 SET RMAMEN=$PIECE(^RMPR(664,RP,2),U,9)
- +13 SET AACNT=$PIECE(^RMPR(664,RP,4),U,3)
- +14 SET CLCNT=$PIECE(^RMPR(664,RP,4),U,4)
- +15 SET CLODT=$PIECE(^RMPR(664,RP,0),U,8)
- +16 IF 'RMAMEN
- SET RMAMEN=0
- +17 IF '$TEST
- SET RMAMEN=RMAMEN-AACNT
- +18 IF $GET(CLODT)
- SET ORCNT2=ORCNT2+1
- +19 IF '$TEST
- SET ORCNT1=ORCNT1+1
- +20 SET NL=NL+AACNT
- SET RMAMTOT=RMAMTOT+RMAMEN
- +21 SET TCLCNT=TCLCNT+CLCNT
- +22 SET RMCUM=$SELECT(CLCNT'="":CLCNT,AACNT'="":AACNT+RMAMEN,1:"")
- +23 ;S:RMCUM'=R660T RMAST="*"
- +24 SET CNT=CNT+RMCUM
- +25 WRITE ?36,$JUSTIFY(AACNT,9,2)
- +26 WRITE ?48,$JUSTIFY(RMAMEN,7,2)
- +27 WRITE ?57,$JUSTIFY(CLCNT,9,2)
- +28 WRITE ?69,$JUSTIFY(CNT,9,2)_RMAST
- +29 SET RMPRFLG=1
- +30 IF $EXTRACT(IOST)["C"&($Y>(IOSL-6))
- WRITE !
- SET DIR(0)="E"
- DO ^DIR
- if Y<1
- SET RMPREND=1
- if Y=""
- QUIT
- if Y<1
- SET RMPRFLL=1
- if Y<1
- QUIT
- if $DATA(DTOUT)
- SET RMPREND=1
- if $DATA(DTOUT)
- QUIT
- DO HDR
- QUIT
- +31 IF $Y>(IOSL-6)
- KILL RMPRFLG
- +32 QUIT
- HDR IF PAGE'=1
- WRITE @IOF
- +1 WRITE !,RMPRX_"-",RMPRY," "_RMPRPCRD_" Summary "_"STA "_$$STA^RMPRUTIL,?72,"PAGE ",PAGE,!
- SET PAGE=PAGE+1
- +2 WRITE !,"Patient",?14,"SSN",?19,"Date",?26,"PC #",?37,"Auth Amt",?48,"Adj Amt",?59,"Liq Amt",?71,"Cum Amt",!,RMPR("L")
- +3 QUIT
