RMPRPIUK ;HINCIO/ODJ - PIP CONVERSION UTILITIES (contd) ;3/8/01
;;3.0;PROSTHETICS;**61**;Feb 09, 1996
Q
;
;***** REC - Create initial reconciliations
; These will balance the Patient Issues just created
REC N RMPRGBL,RMPRS,RMPR6,RMPR11,RMPRDT,X1,X2,X,RMPRTIME,RMPR5,RMPR69
N RMPR9
I '$D(IO("Q")) D
. W !,"Creating balancing reconciliations "
. Q
S RMPRGBL="^TMP("""_$J_""",""ISS"")"
REC1 S RMPRGBL=$Q(@RMPRGBL)
I $QS(RMPRGBL,2)'="ISS" G RECX
I $QS(RMPRGBL,1)'=$J G RECX
I '$D(IO("Q")) D
. W:$X=79 ! W "."
. Q
S RMPR11("STATION")=$QS(RMPRGBL,3)
S RMPR11("STATION IEN")=RMPR11("STATION")
S RMPR11("HCPCS")=$QS(RMPRGBL,4)
S RMPR11("ITEM")=$QS(RMPRGBL,5)
S RMPR6("LOCATION")=$QS(RMPRGBL,6)
S RMPR5("IEN")=RMPR6("LOCATION")
S RMPR6("VENDOR")=$QS(RMPRGBL,7)
S RMPR6("VENDOR IEN")=RMPR6("VENDOR")
S RMPR6("COMMENT")=""
S RMPR6("USER")=DUZ
S RMPRS=@RMPRGBL
S RMPR6("QUANTITY")=$P(RMPRS,"^",1)
S RMPR6("VALUE")=$P(RMPRS,"^",2)
;
; ensure initial reconciliation date is the first one
S X1=$O(^RMPR(661.6,"XHDS",RMPR11("HCPCS"),""))
S X1=$P(X1,".",1)
S X2=-2
D C^%DTC
S RMPRDT=$P(X,".",1)
;
; compute DATE&TIME for initial reconciliation
S RMPR6("DATE&TIME")=""
F D Q:RMPR6("DATE&TIME")'=""
. D NOW^%DTC
. S RMPRTIME=RMPRDT_"."_$P(%,".",2)
. I $D(^RMPR(661.6,"XHDS",RMPR11("HCPCS"),RMPRTIME)) H (1+$R(3)) Q
. L +^RMPR(661.6,"XHDS",RMPR11("HCPCS"),RMPRTIME):0 E H (1+$R(3)) Q
. S RMPR6("DATE&TIME")=RMPRTIME
. Q
;
; create transaction
S RMPR6("SEQUENCE")=1
S RMPR6("TRAN TYPE")=9
S RMPRERR=$$CRE^RMPRPIX6(.RMPR6,.RMPR11)
K RMPR69
S RMPR69("TRANS IEN")=RMPR6("IEN")
S RMPR69("GAIN/LOSS")=RMPR6("QUANTITY")
S RMPR69("GAIN/LOSS VALUE")=RMPR6("VALUE")
S RMPRERR=$$CRE^RMPRPIXB(.RMPR69)
L -^RMPR(661.6,"XHDS",RMPR11("HCPCS"),RMPR6("DATE&TIME"))
G REC1
RECX Q
;
;***** BAL - update running balance file
BAL N RMPR6,RMPR9,RMPRDT,RMPRS,RMPRH,RMPRI,RMPRD,RMPRQ,RMPRV,RMPRX,RMPRY
N RMPRIEN,RMPRFME
I '$D(IO("Q")) D
. W !,"Creating Running Balance file 661.9 "
. Q
S RMPRS=""
F S RMPRS=$O(^RMPR(661.6,"ASTHIDS",RMPRS)) Q:RMPRS="" D
. I '$D(IO("Q")) D
.. W:$X=79 ! W "."
.. Q
. S RMPRH=""
. F S RMPRH=$O(^RMPR(661.6,"ASTHIDS",RMPRS,9,RMPRH)) Q:RMPRH="" D
.. S RMPRI=""
.. F S RMPRI=$O(^RMPR(661.6,"ASTHIDS",RMPRS,9,RMPRH,RMPRI)) Q:RMPRI="" D
... Q:'$D(^RMPR(661.6,"ASTHIDS",RMPRS,3,RMPRH,RMPRI))
... S RMPRD=$O(^RMPR(661.6,"ASTHIDS",RMPRS,9,RMPRH,RMPRI,""))
... S RMPRQ=0,RMPRV=0,RMPRX=""
... F S RMPRX=$O(^RMPR(661.6,"ASTHIDS",RMPRS,9,RMPRH,RMPRI,RMPRD,RMPRX)) Q:RMPRX="" D
.... S RMPRY=""
.... F S RMPRY=$O(^RMPR(661.6,"ASTHIDS",RMPRS,9,RMPRH,RMPRI,RMPRD,RMPRX,RMPRY)) Q:RMPRY="" D
..... S RMPR6=^RMPR(661.6,RMPRY,0)
..... S RMPRQ=RMPRQ+$P(RMPR6,"^",5)
..... S RMPRV=RMPRV+$P(RMPR6,"^",6)
..... Q
.... Q
... I RMPRQ<0 S RMPRQ=0
... I RMPRV<0 S RMPRV=0
... K RMPR9,RMPRIEN,RMPRFME
... S RMPR9(661.9,"+1,",.01)=$P(RMPRD,".",1)
... S RMPR9(661.9,"+1,",1)=RMPRH
... S RMPR9(661.9,"+1,",2)=RMPRI
... S RMPR9(661.9,"+1,",4)=RMPRS
... S RMPR9(661.9,"+1,",7)=RMPRQ
... S RMPR9(661.9,"+1,",8)=RMPRV
... D UPDATE^DIE("","RMPR9","RMPRIEN","RMPRFME")
... F S RMPRD=$O(^RMPR(661.6,"ASTHIDS",RMPRS,3,RMPRH,RMPRI,RMPRD)) Q:RMPRD="" D
.... S RMPRX=""
.... F S RMPRX=$O(^RMPR(661.6,"ASTHIDS",RMPRS,3,RMPRH,RMPRI,RMPRD,RMPRX)) Q:RMPRX="" D
..... S RMPRY=""
..... F S RMPRY=$O(^RMPR(661.6,"ASTHIDS",RMPRS,3,RMPRH,RMPRI,RMPRD,RMPRX,RMPRY)) Q:RMPRY="" D
...... S RMPR6=^RMPR(661.6,RMPRY,0)
...... S RMPRQ=RMPRQ-$P(RMPR6,"^",5)
...... S RMPRV=RMPRV-$P(RMPR6,"^",6)
...... Q
..... Q
.... K RMPR9,RMPRIEN,RMPRFME
.... I RMPRQ<0 S RMPRQ=0
.... I RMPRV<0 S RMPRV=0
.... S RMPR9(661.9,"+1,",.01)=$P(RMPRD,".",1)
.... S RMPR9(661.9,"+1,",1)=RMPRH
.... S RMPR9(661.9,"+1,",2)=RMPRI
.... S RMPR9(661.9,"+1,",4)=RMPRS
.... S RMPR9(661.9,"+1,",7)=RMPRQ
.... S RMPR9(661.9,"+1,",8)=RMPRV
.... D UPDATE^DIE("","RMPR9","RMPRIEN","RMPRFME")
.... Q
... Q
.. Q
. Q
BALX Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIUK 4083 printed Nov 22, 2024@17:46:30 Page 2
RMPRPIUK ;HINCIO/ODJ - PIP CONVERSION UTILITIES (contd) ;3/8/01
+1 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
+2 QUIT
+3 ;
+4 ;***** REC - Create initial reconciliations
+5 ; These will balance the Patient Issues just created
REC NEW RMPRGBL,RMPRS,RMPR6,RMPR11,RMPRDT,X1,X2,X,RMPRTIME,RMPR5,RMPR69
+1 NEW RMPR9
+2 IF '$DATA(IO("Q"))
Begin DoDot:1
+3 WRITE !,"Creating balancing reconciliations "
+4 QUIT
End DoDot:1
+5 SET RMPRGBL="^TMP("""_$JOB_""",""ISS"")"
REC1 SET RMPRGBL=$QUERY(@RMPRGBL)
+1 IF $QSUBSCRIPT(RMPRGBL,2)'="ISS"
GOTO RECX
+2 IF $QSUBSCRIPT(RMPRGBL,1)'=$JOB
GOTO RECX
+3 IF '$DATA(IO("Q"))
Begin DoDot:1
+4 if $X=79
WRITE !
WRITE "."
+5 QUIT
End DoDot:1
+6 SET RMPR11("STATION")=$QSUBSCRIPT(RMPRGBL,3)
+7 SET RMPR11("STATION IEN")=RMPR11("STATION")
+8 SET RMPR11("HCPCS")=$QSUBSCRIPT(RMPRGBL,4)
+9 SET RMPR11("ITEM")=$QSUBSCRIPT(RMPRGBL,5)
+10 SET RMPR6("LOCATION")=$QSUBSCRIPT(RMPRGBL,6)
+11 SET RMPR5("IEN")=RMPR6("LOCATION")
+12 SET RMPR6("VENDOR")=$QSUBSCRIPT(RMPRGBL,7)
+13 SET RMPR6("VENDOR IEN")=RMPR6("VENDOR")
+14 SET RMPR6("COMMENT")=""
+15 SET RMPR6("USER")=DUZ
+16 SET RMPRS=@RMPRGBL
+17 SET RMPR6("QUANTITY")=$PIECE(RMPRS,"^",1)
+18 SET RMPR6("VALUE")=$PIECE(RMPRS,"^",2)
+19 ;
+20 ; ensure initial reconciliation date is the first one
+21 SET X1=$ORDER(^RMPR(661.6,"XHDS",RMPR11("HCPCS"),""))
+22 SET X1=$PIECE(X1,".",1)
+23 SET X2=-2
+24 DO C^%DTC
+25 SET RMPRDT=$PIECE(X,".",1)
+26 ;
+27 ; compute DATE&TIME for initial reconciliation
+28 SET RMPR6("DATE&TIME")=""
+29 FOR
Begin DoDot:1
+30 DO NOW^%DTC
+31 SET RMPRTIME=RMPRDT_"."_$PIECE(%,".",2)
+32 IF $DATA(^RMPR(661.6,"XHDS",RMPR11("HCPCS"),RMPRTIME))
HANG (1+$RANDOM(3))
QUIT
+33 LOCK +^RMPR(661.6,"XHDS",RMPR11("HCPCS"),RMPRTIME):0
IF '$TEST
HANG (1+$RANDOM(3))
QUIT
+34 SET RMPR6("DATE&TIME")=RMPRTIME
+35 QUIT
End DoDot:1
if RMPR6("DATE&TIME")'=""
QUIT
+36 ;
+37 ; create transaction
+38 SET RMPR6("SEQUENCE")=1
+39 SET RMPR6("TRAN TYPE")=9
+40 SET RMPRERR=$$CRE^RMPRPIX6(.RMPR6,.RMPR11)
+41 KILL RMPR69
+42 SET RMPR69("TRANS IEN")=RMPR6("IEN")
+43 SET RMPR69("GAIN/LOSS")=RMPR6("QUANTITY")
+44 SET RMPR69("GAIN/LOSS VALUE")=RMPR6("VALUE")
+45 SET RMPRERR=$$CRE^RMPRPIXB(.RMPR69)
+46 LOCK -^RMPR(661.6,"XHDS",RMPR11("HCPCS"),RMPR6("DATE&TIME"))
+47 GOTO REC1
RECX QUIT
+1 ;
+2 ;***** BAL - update running balance file
BAL NEW RMPR6,RMPR9,RMPRDT,RMPRS,RMPRH,RMPRI,RMPRD,RMPRQ,RMPRV,RMPRX,RMPRY
+1 NEW RMPRIEN,RMPRFME
+2 IF '$DATA(IO("Q"))
Begin DoDot:1
+3 WRITE !,"Creating Running Balance file 661.9 "
+4 QUIT
End DoDot:1
+5 SET RMPRS=""
+6 FOR
SET RMPRS=$ORDER(^RMPR(661.6,"ASTHIDS",RMPRS))
if RMPRS=""
QUIT
Begin DoDot:1
+7 IF '$DATA(IO("Q"))
Begin DoDot:2
+8 if $X=79
WRITE !
WRITE "."
+9 QUIT
End DoDot:2
+10 SET RMPRH=""
+11 FOR
SET RMPRH=$ORDER(^RMPR(661.6,"ASTHIDS",RMPRS,9,RMPRH))
if RMPRH=""
QUIT
Begin DoDot:2
+12 SET RMPRI=""
+13 FOR
SET RMPRI=$ORDER(^RMPR(661.6,"ASTHIDS",RMPRS,9,RMPRH,RMPRI))
if RMPRI=""
QUIT
Begin DoDot:3
+14 if '$DATA(^RMPR(661.6,"ASTHIDS",RMPRS,3,RMPRH,RMPRI))
QUIT
+15 SET RMPRD=$ORDER(^RMPR(661.6,"ASTHIDS",RMPRS,9,RMPRH,RMPRI,""))
+16 SET RMPRQ=0
SET RMPRV=0
SET RMPRX=""
+17 FOR
SET RMPRX=$ORDER(^RMPR(661.6,"ASTHIDS",RMPRS,9,RMPRH,RMPRI,RMPRD,RMPRX))
if RMPRX=""
QUIT
Begin DoDot:4
+18 SET RMPRY=""
+19 FOR
SET RMPRY=$ORDER(^RMPR(661.6,"ASTHIDS",RMPRS,9,RMPRH,RMPRI,RMPRD,RMPRX,RMPRY))
if RMPRY=""
QUIT
Begin DoDot:5
+20 SET RMPR6=^RMPR(661.6,RMPRY,0)
+21 SET RMPRQ=RMPRQ+$PIECE(RMPR6,"^",5)
+22 SET RMPRV=RMPRV+$PIECE(RMPR6,"^",6)
+23 QUIT
End DoDot:5
+24 QUIT
End DoDot:4
+25 IF RMPRQ<0
SET RMPRQ=0
+26 IF RMPRV<0
SET RMPRV=0
+27 KILL RMPR9,RMPRIEN,RMPRFME
+28 SET RMPR9(661.9,"+1,",.01)=$PIECE(RMPRD,".",1)
+29 SET RMPR9(661.9,"+1,",1)=RMPRH
+30 SET RMPR9(661.9,"+1,",2)=RMPRI
+31 SET RMPR9(661.9,"+1,",4)=RMPRS
+32 SET RMPR9(661.9,"+1,",7)=RMPRQ
+33 SET RMPR9(661.9,"+1,",8)=RMPRV
+34 DO UPDATE^DIE("","RMPR9","RMPRIEN","RMPRFME")
+35 FOR
SET RMPRD=$ORDER(^RMPR(661.6,"ASTHIDS",RMPRS,3,RMPRH,RMPRI,RMPRD))
if RMPRD=""
QUIT
Begin DoDot:4
+36 SET RMPRX=""
+37 FOR
SET RMPRX=$ORDER(^RMPR(661.6,"ASTHIDS",RMPRS,3,RMPRH,RMPRI,RMPRD,RMPRX))
if RMPRX=""
QUIT
Begin DoDot:5
+38 SET RMPRY=""
+39 FOR
SET RMPRY=$ORDER(^RMPR(661.6,"ASTHIDS",RMPRS,3,RMPRH,RMPRI,RMPRD,RMPRX,RMPRY))
if RMPRY=""
QUIT
Begin DoDot:6
+40 SET RMPR6=^RMPR(661.6,RMPRY,0)
+41 SET RMPRQ=RMPRQ-$PIECE(RMPR6,"^",5)
+42 SET RMPRV=RMPRV-$PIECE(RMPR6,"^",6)
+43 QUIT
End DoDot:6
+44 QUIT
End DoDot:5
+45 KILL RMPR9,RMPRIEN,RMPRFME
+46 IF RMPRQ<0
SET RMPRQ=0
+47 IF RMPRV<0
SET RMPRV=0
+48 SET RMPR9(661.9,"+1,",.01)=$PIECE(RMPRD,".",1)
+49 SET RMPR9(661.9,"+1,",1)=RMPRH
+50 SET RMPR9(661.9,"+1,",2)=RMPRI
+51 SET RMPR9(661.9,"+1,",4)=RMPRS
+52 SET RMPR9(661.9,"+1,",7)=RMPRQ
+53 SET RMPR9(661.9,"+1,",8)=RMPRV
+54 DO UPDATE^DIE("","RMPR9","RMPRIEN","RMPRFME")
+55 QUIT
End DoDot:4
+56 QUIT
End DoDot:3
+57 QUIT
End DoDot:2
+58 QUIT
End DoDot:1
BALX QUIT
