- RMPRPCER ;HIN/RVD-PRINT PCE DATA ;7/3/01
- ;;3.0;PROSTHETICS;**62**;Feb 09, 1996
- ;RVD 7/3/01 patch #62 - PCE data print
- ;
- 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 PCE DATA",ZTRTN="PRINT^RMPRPCER",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 RMRDAT=$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
- .S RM0=$G(^RMPR(660,RJ,0))
- .S RM10=$G(^RMPR(660,RJ,10))
- .Q:$P(RM10,U,12)'>0
- .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,8)
- ..I $D(^DPT(RMDFN,0)) S RMPAT=$E($P(^DPT(RMDFN,0),U,1),U,10)
- ..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 RMTYRE=$P(RM10,U,5)
- ..S RMSURE=$P(RM10,U,6)
- ..S RMPRDI=$P(RM10,U,7)
- ..S RMICD9=$P(RM10,U,8)
- ..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 RMICD9,($D(^ICD9(RMICD9,0))) S RMICD=$P(^ICD9(RMICD9,0),U,1)
- ..E S RMICD=""
- ..S:RMTYRE'="" RMTYRE=$E(RMTYRE,1,8)
- ..I RMSURE,($D(^VA(200,RMSURE,0))) S RMSURE=$E($P(^VA(200,RMSURE,0),U,1),1,9)
- ..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)=RMITEM_"^"_RDDT_"^"_RMTYRE_"^"_RMSURE_"^"_RMICD_"^"_RPDT_"^"_$E(RMPRDI,1,9)
- Q
- ;
- WRITE ;write report to a selected device
- S RI=0
- F S RI=$O(^TMP($J,RI)) Q:RI'>0!$G(RMPREND) S RJ="" F S RJ=$O(^TMP($J,RI,RJ)) Q:RJ=""!$G(RMPREND) D
- .S RMDAT=$G(^TMP($J,RI,RJ))
- .S RMPAT=RJ
- .S RMITEM=$P(RMDAT,U,1)
- .S RDDT=$P(RMDAT,U,2)
- .S RMTYRE=$P(RMDAT,U,3)
- .S RMSURE=$P(RMDAT,U,4)
- .S RMICD=$P(RMDAT,U,5)
- .S RPDT=$P(RMDAT,U,6)
- .S RMPRDI=$E($P(RMDAT,U,7),1,12)
- .W !,RDDT,?10,RMPAT,?21,RMITEM,?30,RMTYRE,?40,RMSURE,?51,RMICD,?58,RPDT,?68,RMPRDI
- .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 PCE DATA *** Run Date: ",RMRDAT,?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 !?30,"TYPE OF",?42,"CPRS",?60,"PCE"
- W !,"DATE",?10,"PATIENT",?21,"ITEM",?30,"REQUEST",?40,"REQUESTOR",?51,"ICD9",?60,"DATE",?68,"DIAGNOSIS"
- W !,"----",?10,"-------",?21,"----",?30,"-------",?40,"---------",?51,"----",?58,"--------",?68,"---------"
- 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[HRMPRPCER 4137 printed Feb 19, 2025@00:02:16 Page 2
- RMPRPCER ;HIN/RVD-PRINT PCE DATA ;7/3/01
- +1 ;;3.0;PROSTHETICS;**62**;Feb 09, 1996
- +2 ;RVD 7/3/01 patch #62 - PCE data print
- +3 ;
- +4 DO DIV4^RMPRSIT
- IF $DATA(Y)
- IF (Y<0)
- QUIT
- +5 ; 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 PCE DATA"
- SET ZTRTN="PRINT^RMPRPCER"
- 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 RMRDAT=$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 SET RM0=$GET(^RMPR(660,RJ,0))
- +3 SET RM10=$GET(^RMPR(660,RJ,10))
- +4 if $PIECE(RM10,U,12)'>0
- QUIT
- +5 IF $PIECE(RM0,U,10)=RS
- Begin DoDot:2
- +6 SET RMDFN=$PIECE(RM0,U,2)
- +7 SET RMITIEN=$PIECE(RM0,U,6)
- +8 SET (RMITEM,RMPAT)=""
- +9 IF RMITIEN
- IF ($DATA(^RMPR(661,RMITIEN,0)))
- IF ($DATA(^PRC(441,$PIECE(^RMPR(661,RMITIEN,0),U,1),0)))
- Begin DoDot:3
- +10 SET RMITEM=$PIECE(^PRC(441,$PIECE(^RMPR(661,RMITIEN,0),U,1),0),U,2)
- End DoDot:3
- +11 SET RMITEM=$EXTRACT(RMITEM,1,8)
- +12 IF $DATA(^DPT(RMDFN,0))
- SET RMPAT=$EXTRACT($PIECE(^DPT(RMDFN,0),U,1),U,10)
- +13 SET RMSUSP=$PIECE(RM10,U,1)
- +14 SET RMRXDT=$PIECE(RM10,U,2)
- +15 SET RMIADT=$PIECE(RM10,U,3)
- +16 SET RCDT=$PIECE(RM10,U,4)
- +17 SET RMTYRE=$PIECE(RM10,U,5)
- +18 SET RMSURE=$PIECE(RM10,U,6)
- +19 SET RMPRDI=$PIECE(RM10,U,7)
- +20 SET RMICD9=$PIECE(RM10,U,8)
- +21 SET RMCOSU=$PIECE(RM10,U,9)
- +22 SET RMSUST=$PIECE(RM10,U,11)
- +23 SET RMPCEP=$PIECE(RM10,U,12)
- +24 SET RPDT=$PIECE(RM10,U,13)
- +25 IF RMICD9
- IF ($DATA(^ICD9(RMICD9,0)))
- SET RMICD=$PIECE(^ICD9(RMICD9,0),U,1)
- +26 IF '$TEST
- SET RMICD=""
- +27 if RMTYRE'=""
- SET RMTYRE=$EXTRACT(RMTYRE,1,8)
- +28 IF RMSURE
- IF ($DATA(^VA(200,RMSURE,0)))
- SET RMSURE=$EXTRACT($PIECE(^VA(200,RMSURE,0),U,1),1,9)
- +29 SET RDDT=$EXTRACT(RI,4,5)_"/"_$EXTRACT(RI,6,7)_"/"_$EXTRACT(RI,2,3)
- +30 if RPDT'=""
- SET RPDT=$EXTRACT(RPDT,4,5)_"/"_$EXTRACT(RPDT,6,7)_"/"_$EXTRACT(RPDT,2,3)
- +31 if RCDT'=""
- SET RCDT=$EXTRACT(RCDT,4,5)_"/"_$EXTRACT(RCDT,6,7)_"/"_$EXTRACT(RCDT,2,3)
- +32 SET ^TMP($JOB,RI,RMPAT)=RMITEM_"^"_RDDT_"^"_RMTYRE_"^"_RMSURE_"^"_RMICD_"^"_RPDT_"^"_$EXTRACT(RMPRDI,1,9)
- End DoDot:2
- End DoDot:1
- +33 QUIT
- +34 ;
- WRITE ;write report to a selected device
- +1 SET RI=0
- +2 FOR
- SET RI=$ORDER(^TMP($JOB,RI))
- if RI'>0!$GET(RMPREND)
- QUIT
- SET RJ=""
- FOR
- SET RJ=$ORDER(^TMP($JOB,RI,RJ))
- if RJ=""!$GET(RMPREND)
- QUIT
- Begin DoDot:1
- +3 SET RMDAT=$GET(^TMP($JOB,RI,RJ))
- +4 SET RMPAT=RJ
- +5 SET RMITEM=$PIECE(RMDAT,U,1)
- +6 SET RDDT=$PIECE(RMDAT,U,2)
- +7 SET RMTYRE=$PIECE(RMDAT,U,3)
- +8 SET RMSURE=$PIECE(RMDAT,U,4)
- +9 SET RMICD=$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,?21,RMITEM,?30,RMTYRE,?40,RMSURE,?51,RMICD,?58,RPDT,?68,RMPRDI
- +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 PCE DATA *** Run Date: ",RMRDAT,?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 !?30,"TYPE OF",?42,"CPRS",?60,"PCE"
- +4 WRITE !,"DATE",?10,"PATIENT",?21,"ITEM",?30,"REQUEST",?40,"REQUESTOR",?51,"ICD9",?60,"DATE",?68,"DIAGNOSIS"
- +5 WRITE !,"----",?10,"-------",?21,"----",?30,"-------",?40,"---------",?51,"----",?58,"--------",?68,"---------"
- +6 SET RMPRFLG=1
- +7 QUIT
- +8 ;
- 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