- RMPRSP7 ;HIN/RVD-PRINT 2319 WITHOUT SUSPENSE LINK ;3/17/03 08:13
- ;;3.0;PROSTHETICS;**62,69,77,135**;Feb 09, 1996;Build 12
- ;RVD 8/27/01 patch #62 - PCE data print
- ;RVD 4/9/02 patch #69 - Disregard Historical data
- ;RVD 3/17/02 patch #77 - Fixed For Loop to include all PT 2319 records
- ; that are not linked
- ;RGB 3/22/07 patch 135 - Modified code to check issues in 660 against file 668 suspense records
- ; in addition to current check of complete flag in issue record.
- ;
- D DIV4^RMPRSIT I $D(Y),(Y<0) Q
- ; Prompt for Start Date
- STDT ;RMPRSDT is start date in FM internal form.
- K %DT,X,Y
- S %DT("A")="Starting Date: "
- S %DT(0)=-DT
- S %DT="AEP"
- D ^%DT I Y<0 G EXIT1
- S RMPRSDT=$P(Y,".",1)
- S %DT("A")="Ending Date: ",%DT="AEX" D ^%DT G:Y<0 EXIT1
- S RMPREDT=$P(Y,".",1)
- I RMPRSDT>RMPREDT W !,$C(7),"Invalid Date Range Selection!!" G STDT
- ;
- CONT G:'$D(RMPRSDT) EXIT1 S %ZIS="MQ" K IOP D ^%ZIS G:POP EXIT1 I '$D(IO("Q")) U IO G PRINT
- K IO("Q") S ZTDESC="PROSTHETIC PATIENT RECORDS WITHOUT SUSPENSE",ZTRTN="PRINT^RMPRSP7",ZTIO=ION,ZTSAVE("RMPRSDT")=""
- S ZTSAVE("RMPR(""STA"")")="",ZTSAVE("RMPR(")="",ZTSAVE("RMPREDT")=""
- D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED!" H 1 G EXIT
- ;
- PRINT I $E(IOST)["C" W !!,"Processing report......."
- K ^TMP($J)
- K %DT,X,Y
- S X="NOW" D ^%DT S RMDATE=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)
- S RMPAGE=1,(RMTOBAL,RMPREND)=0,RS=RMPR("STA")
- S RDT=RMPRSDT-1,RET=RMPREDT+1,RS=RMPR("STA")
- S Y=RMPRSDT D DD^%DT S RMSDAT=Y
- S Y=RMPREDT D DD^%DT S RMEDAT=Y
- D BUILD
- I '$D(^TMP($J)) D HEAD,NONE G EXIT
- D HEAD,HEAD1
- D WRITE
- G EXIT
- ;
- BUILD ;build a tmp global.
- F RI=RDT:0:RET S RI=$O(^RMPR(660,"B",RI)) Q:(RI'>0)!(RMPREND)!(RI>RMPREDT) F RJ=0:0 S RJ=$O(^RMPR(660,"B",RI,RJ)) Q:(RJ'>0) D
- .;don't include if O2 transactions.
- .Q:$D(^RMPO(665.72,"AC",RJ))
- .S RM0=$G(^RMPR(660,RJ,0))
- .S RM10=$G(^RMPR(660,RJ,10))
- .Q:($P(RM0,U,13)=13)!($P(RM0,U,15)="*")
- .Q:($P(RM10,U,14)>0)!($P(RM0,U,10)'=RMPR("STA"))
- .;FILTER SHIPPING CHARGES AND DDC TRANSACTIONS
- .Q:($P(RM0,U,17)'="")!($P(RM0,U,13)=16)
- .S RMIE68=$O(^RMPR(668,"F",RJ,0))
- .I RMIE68,$D(^RMPR(668,RMIE68,10,"B",RJ)) Q
- .I $P(RM0,U,10)=RS D
- ..S RMDFN=$P(RM0,U,2)
- ..S RMITIEN=$P(RM0,U,6)
- ..S (RMITEM,RMPAT)=""
- ..I RMITIEN,($D(^RMPR(661,RMITIEN,0))),($D(^PRC(441,$P(^RMPR(661,RMITIEN,0),U,1),0))) D
- ...S RMITEM=$P(^PRC(441,$P(^RMPR(661,RMITIEN,0),U,1),0),U,2)
- ..S RMITEM=$E(RMITEM,1,18)
- ..I $D(^DPT(RMDFN,0)) S RMPAT=$E($P(^DPT(RMDFN,0),U,1),U,15)
- ..S RMSUSP=$P(RM10,U,1)
- ..S RMRXDT=$P(RM10,U,2)
- ..S RMIADT=$P(RM10,U,3)
- ..S RCDT=$P(RM10,U,4)
- ..S RMAMT=$P(RM0,U,16)
- ..S RMSRC=RJ
- ..S RMPRDI=$P(RM10,U,7)
- ..S RMINIE=$P(RM0,U,27)
- ..S RMCOSU=$P(RM10,U,9)
- ..S RMSUST=$P(RM10,U,11)
- ..S RMPCEP=$P(RM10,U,12)
- ..S RPDT=$P(RM10,U,13)
- ..I RMINIE,$D(^VA(200,RMINIE,0)) S RMINI=$E($P(^VA(200,RMINIE,0),U,1),1,10)
- ..E S RMINI=""
- ..S RDDT=$E(RI,4,5)_"/"_$E(RI,6,7)_"/"_$E(RI,2,3)
- ..S:RPDT'="" RPDT=$E(RPDT,4,5)_"/"_$E(RPDT,6,7)_"/"_$E(RPDT,2,3)
- ..S:RCDT'="" RCDT=$E(RCDT,4,5)_"/"_$E(RCDT,6,7)_"/"_$E(RCDT,2,3)
- ..S ^TMP($J,RI,RMPAT,RJ)=RMITEM_"^"_RDDT_"^"_RMAMT_"^"_RMSRC_"^"_RMINI_"^"_RPDT_"^"_$E(RMPRDI,1,10)
- Q
- ;
- WRITE ;write report to a selected device
- S (RMPREND,RI,RM)=0
- F S RI=$O(^TMP($J,RI)) Q:(RI'>0)!(RMPREND) S RJ="" F S RJ=$O(^TMP($J,RI,RJ)) Q:(RJ="")!(RMPREND) F S RM=$O(^TMP($J,RI,RJ,RM)) Q:(RM'>0)!(RMPREND) D
- .S RMDAT=$G(^TMP($J,RI,RJ,RM))
- .S RMPAT=RJ
- .S RMITEM=$P(RMDAT,U,1)
- .S RDDT=$P(RMDAT,U,2)
- .S RMAMT=$P(RMDAT,U,3)
- .S RMSRC=$P(RMDAT,U,4)
- .S RMINI=$P(RMDAT,U,5)
- .S RPDT=$P(RMDAT,U,6)
- .S RMPRDI=$E($P(RMDAT,U,7),1,12)
- .W !,RDDT,?10,RMPAT,?26,RMITEM,?45,$J(RMAMT,8,2),?57,RMSRC,?67,RMINI
- .S RMPRFLG=1
- .I $E(IOST)["C"&($Y>(IOSL-7)) S DIR(0)="E" D ^DIR S:$D(DTOUT)!(Y=0) RMPREND=1 Q:RMPREND W @IOF D HEAD,HEAD1 Q
- .I $Y>(IOSL-6) W @IOF D HEAD,HEAD1 K RMPRFLG Q
- W !,RMPR("L")
- W !,"<End of Report>"
- Q
- ;
- HEAD W !,"PROSTHETICS PATIENT RECORDS NOT LINKED TO SUSPENSE Run Date:",RMDATE,?70,"PAGE: ",RMPAGE
- W !,"Start Date: ",RMSDAT,?26,"End Date: ",RMEDAT,?51,"station: ",$E($P($G(^DIC(4,RS,0)),U,1),1,19)
- S RMPAGE=RMPAGE+1
- Q
- ;
- HEAD1 I $E(IOST)["C"&($Y>(IOSL-7)) S DIR(0)="E" D ^DIR S:$D(DTOUT)!(Y=0) RMPREND=1 Q:RMPREND W @IOF D HEAD
- I $E(IOST)'["C"&($Y>(IOSL-6)) W @IOF D HEAD
- W !,RMPR("L")
- W !,"DATE",?10,"PATIENT",?26,"ITEM",?49,"COST",?57,"VISTA #",?67,"INITIATOR"
- W !,"----",?10,"-------",?26,"----",?49,"----",?57,"-------",?67,"---------"
- S RMPRFLG=1
- Q
- ;
- EXIT I $E(IOST)["C",'RMPREND K DIR S DIR(0)="E" D ^DIR
- EXIT1 D ^%ZISC
- K ^TMP($J)
- N RMPR,RMPRSITE D KILL^XUSCLEAN
- Q
- NONE W !!,"NO DATA TO PRINT !!!!!"
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRSP7 4730 printed Feb 19, 2025@00:04:18 Page 2
- RMPRSP7 ;HIN/RVD-PRINT 2319 WITHOUT SUSPENSE LINK ;3/17/03 08:13
- +1 ;;3.0;PROSTHETICS;**62,69,77,135**;Feb 09, 1996;Build 12
- +2 ;RVD 8/27/01 patch #62 - PCE data print
- +3 ;RVD 4/9/02 patch #69 - Disregard Historical data
- +4 ;RVD 3/17/02 patch #77 - Fixed For Loop to include all PT 2319 records
- +5 ; that are not linked
- +6 ;RGB 3/22/07 patch 135 - Modified code to check issues in 660 against file 668 suspense records
- +7 ; in addition to current check of complete flag in issue record.
- +8 ;
- +9 DO DIV4^RMPRSIT
- IF $DATA(Y)
- IF (Y<0)
- QUIT
- +10 ; Prompt for Start Date
- STDT ;RMPRSDT is start date in FM internal form.
- +1 KILL %DT,X,Y
- +2 SET %DT("A")="Starting Date: "
- +3 SET %DT(0)=-DT
- +4 SET %DT="AEP"
- +5 DO ^%DT
- IF Y<0
- GOTO EXIT1
- +6 SET RMPRSDT=$PIECE(Y,".",1)
- +7 SET %DT("A")="Ending Date: "
- SET %DT="AEX"
- DO ^%DT
- if Y<0
- GOTO EXIT1
- +8 SET RMPREDT=$PIECE(Y,".",1)
- +9 IF RMPRSDT>RMPREDT
- WRITE !,$CHAR(7),"Invalid Date Range Selection!!"
- GOTO STDT
- +10 ;
- CONT if '$DATA(RMPRSDT)
- GOTO EXIT1
- SET %ZIS="MQ"
- KILL IOP
- DO ^%ZIS
- if POP
- GOTO EXIT1
- IF '$DATA(IO("Q"))
- USE IO
- GOTO PRINT
- +1 KILL IO("Q")
- SET ZTDESC="PROSTHETIC PATIENT RECORDS WITHOUT SUSPENSE"
- SET ZTRTN="PRINT^RMPRSP7"
- SET ZTIO=ION
- SET ZTSAVE("RMPRSDT")=""
- +2 SET ZTSAVE("RMPR(""STA"")")=""
- SET ZTSAVE("RMPR(")=""
- SET ZTSAVE("RMPREDT")=""
- +3 DO ^%ZTLOAD
- if $DATA(ZTSK)
- WRITE !,"REQUEST QUEUED!"
- HANG 1
- GOTO EXIT
- +4 ;
- PRINT IF $EXTRACT(IOST)["C"
- WRITE !!,"Processing report......."
- +1 KILL ^TMP($JOB)
- +2 KILL %DT,X,Y
- +3 SET X="NOW"
- DO ^%DT
- SET RMDATE=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)
- +4 SET RMPAGE=1
- SET (RMTOBAL,RMPREND)=0
- SET RS=RMPR("STA")
- +5 SET RDT=RMPRSDT-1
- SET RET=RMPREDT+1
- SET RS=RMPR("STA")
- +6 SET Y=RMPRSDT
- DO DD^%DT
- SET RMSDAT=Y
- +7 SET Y=RMPREDT
- DO DD^%DT
- SET RMEDAT=Y
- +8 DO BUILD
- +9 IF '$DATA(^TMP($JOB))
- DO HEAD
- DO NONE
- GOTO EXIT
- +10 DO HEAD
- DO HEAD1
- +11 DO WRITE
- +12 GOTO EXIT
- +13 ;
- BUILD ;build a tmp global.
- +1 FOR RI=RDT:0:RET
- SET RI=$ORDER(^RMPR(660,"B",RI))
- if (RI'>0)!(RMPREND)!(RI>RMPREDT)
- QUIT
- FOR RJ=0:0
- SET RJ=$ORDER(^RMPR(660,"B",RI,RJ))
- if (RJ'>0)
- QUIT
- Begin DoDot:1
- +2 ;don't include if O2 transactions.
- +3 if $DATA(^RMPO(665.72,"AC",RJ))
- QUIT
- +4 SET RM0=$GET(^RMPR(660,RJ,0))
- +5 SET RM10=$GET(^RMPR(660,RJ,10))
- +6 if ($PIECE(RM0,U,13)=13)!($PIECE(RM0,U,15)="*")
- QUIT
- +7 if ($PIECE(RM10,U,14)>0)!($PIECE(RM0,U,10)'=RMPR("STA"))
- QUIT
- +8 ;FILTER SHIPPING CHARGES AND DDC TRANSACTIONS
- +9 if ($PIECE(RM0,U,17)'="")!($PIECE(RM0,U,13)=16)
- QUIT
- +10 SET RMIE68=$ORDER(^RMPR(668,"F",RJ,0))
- +11 IF RMIE68
- IF $DATA(^RMPR(668,RMIE68,10,"B",RJ))
- QUIT
- +12 IF $PIECE(RM0,U,10)=RS
- Begin DoDot:2
- +13 SET RMDFN=$PIECE(RM0,U,2)
- +14 SET RMITIEN=$PIECE(RM0,U,6)
- +15 SET (RMITEM,RMPAT)=""
- +16 IF RMITIEN
- IF ($DATA(^RMPR(661,RMITIEN,0)))
- IF ($DATA(^PRC(441,$PIECE(^RMPR(661,RMITIEN,0),U,1),0)))
- Begin DoDot:3
- +17 SET RMITEM=$PIECE(^PRC(441,$PIECE(^RMPR(661,RMITIEN,0),U,1),0),U,2)
- End DoDot:3
- +18 SET RMITEM=$EXTRACT(RMITEM,1,18)
- +19 IF $DATA(^DPT(RMDFN,0))
- SET RMPAT=$EXTRACT($PIECE(^DPT(RMDFN,0),U,1),U,15)
- +20 SET RMSUSP=$PIECE(RM10,U,1)
- +21 SET RMRXDT=$PIECE(RM10,U,2)
- +22 SET RMIADT=$PIECE(RM10,U,3)
- +23 SET RCDT=$PIECE(RM10,U,4)
- +24 SET RMAMT=$PIECE(RM0,U,16)
- +25 SET RMSRC=RJ
- +26 SET RMPRDI=$PIECE(RM10,U,7)
- +27 SET RMINIE=$PIECE(RM0,U,27)
- +28 SET RMCOSU=$PIECE(RM10,U,9)
- +29 SET RMSUST=$PIECE(RM10,U,11)
- +30 SET RMPCEP=$PIECE(RM10,U,12)
- +31 SET RPDT=$PIECE(RM10,U,13)
- +32 IF RMINIE
- IF $DATA(^VA(200,RMINIE,0))
- SET RMINI=$EXTRACT($PIECE(^VA(200,RMINIE,0),U,1),1,10)
- +33 IF '$TEST
- SET RMINI=""
- +34 SET RDDT=$EXTRACT(RI,4,5)_"/"_$EXTRACT(RI,6,7)_"/"_$EXTRACT(RI,2,3)
- +35 if RPDT'=""
- SET RPDT=$EXTRACT(RPDT,4,5)_"/"_$EXTRACT(RPDT,6,7)_"/"_$EXTRACT(RPDT,2,3)
- +36 if RCDT'=""
- SET RCDT=$EXTRACT(RCDT,4,5)_"/"_$EXTRACT(RCDT,6,7)_"/"_$EXTRACT(RCDT,2,3)
- +37 SET ^TMP($JOB,RI,RMPAT,RJ)=RMITEM_"^"_RDDT_"^"_RMAMT_"^"_RMSRC_"^"_RMINI_"^"_RPDT_"^"_$EXTRACT(RMPRDI,1,10)
- End DoDot:2
- End DoDot:1
- +38 QUIT
- +39 ;
- WRITE ;write report to a selected device
- +1 SET (RMPREND,RI,RM)=0
- +2 FOR
- SET RI=$ORDER(^TMP($JOB,RI))
- if (RI'>0)!(RMPREND)
- QUIT
- SET RJ=""
- FOR
- SET RJ=$ORDER(^TMP($JOB,RI,RJ))
- if (RJ="")!(RMPREND)
- QUIT
- FOR
- SET RM=$ORDER(^TMP($JOB,RI,RJ,RM))
- if (RM'>0)!(RMPREND)
- QUIT
- Begin DoDot:1
- +3 SET RMDAT=$GET(^TMP($JOB,RI,RJ,RM))
- +4 SET RMPAT=RJ
- +5 SET RMITEM=$PIECE(RMDAT,U,1)
- +6 SET RDDT=$PIECE(RMDAT,U,2)
- +7 SET RMAMT=$PIECE(RMDAT,U,3)
- +8 SET RMSRC=$PIECE(RMDAT,U,4)
- +9 SET RMINI=$PIECE(RMDAT,U,5)
- +10 SET RPDT=$PIECE(RMDAT,U,6)
- +11 SET RMPRDI=$EXTRACT($PIECE(RMDAT,U,7),1,12)
- +12 WRITE !,RDDT,?10,RMPAT,?26,RMITEM,?45,$JUSTIFY(RMAMT,8,2),?57,RMSRC,?67,RMINI
- +13 SET RMPRFLG=1
- +14 IF $EXTRACT(IOST)["C"&($Y>(IOSL-7))
- SET DIR(0)="E"
- DO ^DIR
- if $DATA(DTOUT)!(Y=0)
- SET RMPREND=1
- if RMPREND
- QUIT
- WRITE @IOF
- DO HEAD
- DO HEAD1
- QUIT
- +15 IF $Y>(IOSL-6)
- WRITE @IOF
- DO HEAD
- DO HEAD1
- KILL RMPRFLG
- QUIT
- End DoDot:1
- +16 WRITE !,RMPR("L")
- +17 WRITE !,"<End of Report>"
- +18 QUIT
- +19 ;
- HEAD WRITE !,"PROSTHETICS PATIENT RECORDS NOT LINKED TO SUSPENSE Run Date:",RMDATE,?70,"PAGE: ",RMPAGE
- +1 WRITE !,"Start Date: ",RMSDAT,?26,"End Date: ",RMEDAT,?51,"station: ",$EXTRACT($PIECE($GET(^DIC(4,RS,0)),U,1),1,19)
- +2 SET RMPAGE=RMPAGE+1
- +3 QUIT
- +4 ;
- HEAD1 IF $EXTRACT(IOST)["C"&($Y>(IOSL-7))
- SET DIR(0)="E"
- DO ^DIR
- if $DATA(DTOUT)!(Y=0)
- SET RMPREND=1
- if RMPREND
- QUIT
- WRITE @IOF
- DO HEAD
- +1 IF $EXTRACT(IOST)'["C"&($Y>(IOSL-6))
- WRITE @IOF
- DO HEAD
- +2 WRITE !,RMPR("L")
- +3 WRITE !,"DATE",?10,"PATIENT",?26,"ITEM",?49,"COST",?57,"VISTA #",?67,"INITIATOR"
- +4 WRITE !,"----",?10,"-------",?26,"----",?49,"----",?57,"-------",?67,"---------"
- +5 SET RMPRFLG=1
- +6 QUIT
- +7 ;
- EXIT IF $EXTRACT(IOST)["C"
- IF 'RMPREND
- KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- EXIT1 DO ^%ZISC
- +1 KILL ^TMP($JOB)
- +2 NEW RMPR,RMPRSITE
- DO KILL^XUSCLEAN
- +3 QUIT
- NONE WRITE !!,"NO DATA TO PRINT !!!!!"
- +1 QUIT
