- RMPR4LOP ;PHX/HNB - LIST OPEN PURCHASE CARD TRANSACTIONS ;3/1/1996
- ;;3.0;PROSTHETICS;**3,20,140**;Feb 09, 1996;Build 10
- ;sort by originator, assistance from Long Beach PVB
- W !,"This report lists Open Purchase Card Transactions created in the"
- W !,"Prosthetics Package."
- W !!,"This report is sorted by Transaction Date and Initiator.",!
- W !,"The PC # column is the abbreviated Purchase Card Transaction Number,"
- W !,"Example: 644-PC546, would display as 546.",!!
- 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
- S %ZIS="MQ" K IOP D ^%ZIS G:POP EX
- I '$D(IO("Q")) U IO G PRINT
- S ZTDESC="OPEN 2421PC TRANSACTIONS",ZTRTN="PRINT^RMPR4LOP",ZTSAVE("RMPRBDT")="",ZTSAVE("RMPREDT")="",ZTSAVE("RMPRX")="",ZTSAVE("RMPRY")="",ZTSAVE("RMPR(")=""
- 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,INIC="",RMPREND="" I IOST["C-" D WAIT^DICD
- 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
- S (RP,RMPROBL,CNT)=""
- F S RMPROBL=$O(^TMP($J,RMPROBL)) Q:RMPROBL'>0 Q:RMPREND=1 D I RMPREND'=1 W !,?71,"=========",!,?65,"Total ",$J($FN(CNT,"P",2),9) S CNT=0 H 1
- .F S RP=$O(^TMP($J,RMPROBL,RP)) Q:RP'>0 Q:RMPREND=1 S INIB=$P(^VA(200,$P(^RMPR(664,RP,0),U,9),0),U,1) D WRI
- I $D(RMPREDT)&(RMPRCOUN=0) W @IOF D HDR W $C(7),!!,"NO SELECTIONS MADE DURING THIS DATE RANGE!!"
- ;
- 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),PRCIEN D ^%ZISC
- K CNT,DTOUT,ROBL,X1,X2,RMPR,%ZIS,INIC,INIB
- Q
- CK ;check record, apply screen
- Q:'$D(^RMPR(664,RP,0))
- ;vendor, purchase card, cancelation date, close-out date
- Q:$P(^RMPR(664,RP,0),U,4)=""!($P($G(^(4)),U,1)="")!($P(^(0),U,5)'="")!($P(^(0),U,8)'="")
- Q:$P(^RMPR(664,RP,0),U,14)'=""&($P(^(0),U,14)'=RMPR("STA"))
- S RMPROBL=$P(^RMPR(664,RP,0),U,9)
- Q:'RMPROBL
- S ^TMP($J,RMPROBL,RP)="",RMPRCOUN=RMPRCOUN+1
- Q
- WRI I '$D(RMPRFLG)!(INIC'=INIB) D HDR W !,"Initiator: ",INIB,!,"Patient",?14,"SSN",?19,"Purchase Card",?36,"Date",?43,"PC #",?50,"Vendor",?62,"Item",?70,"Item Cost",!,RMPR("L")
- 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)
- W ?19
- I DUZ=$P(^RMPR(664,RP,0),U,9)!($D(^XUSEC("RMPR FCP MANAGER",DUZ))) W $$DEC^RMPR4LI($P(^RMPR(664,RP,4),U,1),$P(^RMPR(664,RP,0),U,9),RP)
- E W "encrypted"
- S RD=$P(^RMPR(664,RP,0),U,1),PRCIEN=$P(^RMPR(664,RP,4),U,6)
- S RD=$P(RD,"."),RD=$E(RD,4,5)_"/"_$E(RD,6,7)
- W ?36,RD I PRCIEN,($P($G(^PRC(442,PRCIEN,7)),U)=45) W "#"
- W ?43,$P(^RMPR(664,RP,4),U,5)
- W ?50
- W:+$P(^RMPR(664,RP,0),U,4) $E($P(^PRC(440,$P(^RMPR(664,RP,0),U,4),0),U,1),1,10)
- D ITE
- S INIC=INIB
- Q
- ITE I '$D(^RMPR(664,RP,1))&($P(^RMPR(664,RP,0),U,12)) W ?61,"*DELIVERY",?71,$J($FN($P(^RMPR(660,$P(^RMPR(664,RP,0),U,12),0),U,16),"P",2),9) S RMPRFLG=1
- I S CNT=CNT+$P(^RMPR(660,$P(^RMPR(664,RP,0),U,12),0),U,16) D:$Y>(IOSL-6) HDR Q
- I $P(^RMPR(664,RP,0),U,12)'="" W ?61,"*SHIPPING",?71,$J($FN($P(^RMPR(660,$P(^RMPR(664,RP,0),U,12),0),U,17),"P",2),9),!
- I S CNT=CNT+$P(^RMPR(660,$P(^RMPR(664,RP,0),U,12),0),U,17)
- S (IT)=0
- F S IT=$O(^RMPR(664,RP,1,IT)) Q:IT'>0!($D(DUOUT))!($D(DTOUT)) W:IT>1 ! W ?61,$E($P(^PRC(441,$P(^RMPR(661,$P(^RMPR(664,RP,1,IT,0),U,1),0),U,1),0),U,2),1,10) Q:$P(^RMPR(664,RP,1,IT,0),U,13)="" D COST
- Q
- COST W ?71
- W $J($FN($P(^RMPR(660,$P(^RMPR(664,RP,1,IT,0),U,13),0),U,16),"P",2),9)
- S CNT=CNT+$P(^RMPR(660,$P(^RMPR(664,RP,1,IT,0),U,13),0),U,16)
- 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
- ;header
- I $E(IOST)["C"&($Y<20) F W ! Q:$Y>20
- I INIC'=""!(PAGE'=1)&(INIC'=INIB)&($E(IOST)["C") S DIR(0)="E" D ^DIR
- HDR I PAGE'=1!($E(IOST)["C") W @IOF
- I $E(IOST)["C" W @IOF G EXIT:X="^"
- W !,RMPRX_"-",RMPRY," Open 2421PC Transactions "_"STA "_$$STA^RMPRUTIL,?72,"PAGE ",PAGE,!,"# = PURCHASE CARD Order CANCELLED on IFCAP SYSTEM",! S PAGE=PAGE+1 Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR4LOP 4494 printed Apr 23, 2025@18:47:20 Page 2
- RMPR4LOP ;PHX/HNB - LIST OPEN PURCHASE CARD TRANSACTIONS ;3/1/1996
- +1 ;;3.0;PROSTHETICS;**3,20,140**;Feb 09, 1996;Build 10
- +2 ;sort by originator, assistance from Long Beach PVB
- +3 WRITE !,"This report lists Open Purchase Card Transactions created in the"
- +4 WRITE !,"Prosthetics Package."
- +5 WRITE !!,"This report is sorted by Transaction Date and Initiator.",!
- +6 WRITE !,"The PC # column is the abbreviated Purchase Card Transaction Number,"
- +7 WRITE !,"Example: 644-PC546, would display as 546.",!!
- 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
- +3 SET %ZIS="MQ"
- KILL IOP
- DO ^%ZIS
- if POP
- GOTO EX
- +4 IF '$DATA(IO("Q"))
- USE IO
- GOTO PRINT
- +5 SET ZTDESC="OPEN 2421PC TRANSACTIONS"
- SET ZTRTN="PRINT^RMPR4LOP"
- SET ZTSAVE("RMPRBDT")=""
- SET ZTSAVE("RMPREDT")=""
- SET ZTSAVE("RMPRX")=""
- SET ZTSAVE("RMPRY")=""
- SET ZTSAVE("RMPR(")=""
- +6 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 INIC=""
- SET RMPREND=""
- IF IOST["C-"
- DO WAIT^DICD
- +1 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
- +2 SET (RP,RMPROBL,CNT)=""
- +3 FOR
- SET RMPROBL=$ORDER(^TMP($JOB,RMPROBL))
- if RMPROBL'>0
- QUIT
- if RMPREND=1
- QUIT
- Begin DoDot:1
- +4 FOR
- SET RP=$ORDER(^TMP($JOB,RMPROBL,RP))
- if RP'>0
- QUIT
- if RMPREND=1
- QUIT
- SET INIB=$PIECE(^VA(200,$PIECE(^RMPR(664,RP,0),U,9),0),U,1)
- DO WRI
- End DoDot:1
- IF RMPREND'=1
- WRITE !,?71,"=========",!,?65,"Total ",$JUSTIFY($FNUMBER(CNT,"P",2),9)
- SET CNT=0
- HANG 1
- +5 IF $DATA(RMPREDT)&(RMPRCOUN=0)
- WRITE @IOF
- DO HDR
- WRITE $CHAR(7),!!,"NO SELECTIONS MADE DURING THIS DATE RANGE!!"
- +6 ;
- 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),PRCIEN
- DO ^%ZISC
- +1 KILL CNT,DTOUT,ROBL,X1,X2,RMPR,%ZIS,INIC,INIB
- +2 QUIT
- CK ;check record, apply screen
- +1 if '$DATA(^RMPR(664,RP,0))
- QUIT
- +2 ;vendor, purchase card, cancelation date, close-out date
- +3 if $PIECE(^RMPR(664,RP,0),U,4)=""!($PIECE($GET(^(4)),U,1)="")!($PIECE(^(0),U,5)'="")!($PIECE(^(0),U,8)'="")
- QUIT
- +4 if $PIECE(^RMPR(664,RP,0),U,14)'=""&($PIECE(^(0),U,14)'=RMPR("STA"))
- QUIT
- +5 SET RMPROBL=$PIECE(^RMPR(664,RP,0),U,9)
- +6 if 'RMPROBL
- QUIT
- +7 SET ^TMP($JOB,RMPROBL,RP)=""
- SET RMPRCOUN=RMPRCOUN+1
- +8 QUIT
- WRI IF '$DATA(RMPRFLG)!(INIC'=INIB)
- DO HDR
- WRITE !,"Initiator: ",INIB,!,"Patient",?14,"SSN",?19,"Purchase Card",?36,"Date",?43,"PC #",?50,"Vendor",?62,"Item",?70,"Item Cost",!,RMPR("L")
- +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 WRITE ?19
- +4 IF DUZ=$PIECE(^RMPR(664,RP,0),U,9)!($DATA(^XUSEC("RMPR FCP MANAGER",DUZ)))
- WRITE $$DEC^RMPR4LI($PIECE(^RMPR(664,RP,4),U,1),$PIECE(^RMPR(664,RP,0),U,9),RP)
- +5 IF '$TEST
- WRITE "encrypted"
- +6 SET RD=$PIECE(^RMPR(664,RP,0),U,1)
- SET PRCIEN=$PIECE(^RMPR(664,RP,4),U,6)
- +7 SET RD=$PIECE(RD,".")
- SET RD=$EXTRACT(RD,4,5)_"/"_$EXTRACT(RD,6,7)
- +8 WRITE ?36,RD
- IF PRCIEN
- IF ($PIECE($GET(^PRC(442,PRCIEN,7)),U)=45)
- WRITE "#"
- +9 WRITE ?43,$PIECE(^RMPR(664,RP,4),U,5)
- +10 WRITE ?50
- +11 if +$PIECE(^RMPR(664,RP,0),U,4)
- WRITE $EXTRACT($PIECE(^PRC(440,$PIECE(^RMPR(664,RP,0),U,4),0),U,1),1,10)
- +12 DO ITE
- +13 SET INIC=INIB
- +14 QUIT
- ITE IF '$DATA(^RMPR(664,RP,1))&($PIECE(^RMPR(664,RP,0),U,12))
- WRITE ?61,"*DELIVERY",?71,$JUSTIFY($FNUMBER($PIECE(^RMPR(660,$PIECE(^RMPR(664,RP,0),U,12),0),U,16),"P",2),9)
- SET RMPRFLG=1
- +1 IF $TEST
- SET CNT=CNT+$PIECE(^RMPR(660,$PIECE(^RMPR(664,RP,0),U,12),0),U,16)
- if $Y>(IOSL-6)
- DO HDR
- QUIT
- +2 IF $PIECE(^RMPR(664,RP,0),U,12)'=""
- WRITE ?61,"*SHIPPING",?71,$JUSTIFY($FNUMBER($PIECE(^RMPR(660,$PIECE(^RMPR(664,RP,0),U,12),0),U,17),"P",2),9),!
- +3 IF $TEST
- SET CNT=CNT+$PIECE(^RMPR(660,$PIECE(^RMPR(664,RP,0),U,12),0),U,17)
- +4 SET (IT)=0
- +5 FOR
- SET IT=$ORDER(^RMPR(664,RP,1,IT))
- if IT'>0!($DATA(DUOUT))!($DATA(DTOUT))
- QUIT
- if IT>1
- WRITE !
- WRITE ?61,$EXTRACT($PIECE(^PRC(441,$PIECE(^RMPR(661,$PIECE(^RMPR(664,RP,1,IT,0),U,1),0),U,1),0),U,2),1,10)
- if $PIECE(^RMPR(664,RP,1,IT,0),U,13)=""
- QUIT
- DO COST
- +6 QUIT
- COST WRITE ?71
- +1 WRITE $JUSTIFY($FNUMBER($PIECE(^RMPR(660,$PIECE(^RMPR(664,RP,1,IT,0),U,13),0),U,16),"P",2),9)
- +2 SET CNT=CNT+$PIECE(^RMPR(660,$PIECE(^RMPR(664,RP,1,IT,0),U,13),0),U,16)
- +3 SET RMPRFLG=1
- +4 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
- +5 IF $Y>(IOSL-6)
- KILL RMPRFLG
- +6 QUIT
- +7 ;header
- +8 IF $EXTRACT(IOST)["C"&($Y<20)
- FOR
- WRITE !
- if $Y>20
- QUIT
- +9 IF INIC'=""!(PAGE'=1)&(INIC'=INIB)&($EXTRACT(IOST)["C")
- SET DIR(0)="E"
- DO ^DIR
- HDR IF PAGE'=1!($EXTRACT(IOST)["C")
- WRITE @IOF
- +1 IF $EXTRACT(IOST)["C"
- WRITE @IOF
- if X="^"
- GOTO EXIT
- +2 WRITE !,RMPRX_"-",RMPRY," Open 2421PC Transactions "_"STA "_$$STA^RMPRUTIL,?72,"PAGE ",PAGE,!,"# = PURCHASE CARD Order CANCELLED on IFCAP SYSTEM",!
- SET PAGE=PAGE+1
- QUIT
