RMPR9S7 ;HOIFO/HNC - GUI 2319 TAB 7 HISA TRANSACTIONS LIST ;9/10/02 08:43
;;3.0;PROSTHETICS;**59,160**;Feb 09, 1996;Build 14
;
Q
A1(IEN) G A2
EN(RESULTS,IEN) ;broker
A2 S (RA,AN,ANS,RK,RZ)=0 K ^TMP($J,"TT"),^TMP($J,"AG"),IT
K ^TMP($J,"RMPRB")
K ^TMP($J,"RMPRC")
;IT IS RESULTS
;0;2 DFN in 668
S RMPRDFN=$P($G(^RMPR(668,IEN,0)),U,2)
I RMPRDFN="" S ^TMP($J,"RMPRB",1)="PATIENT NOT KNOWN" Q
MERGE ^TMP($J,"TT")=^RMPR(660,"AC",RMPRDFN)
S B=0
F S B=$O(^TMP($J,"TT",B)) Q:B'>0 D
. S BC=0
. F S BC=$O(^TMP($J,"TT",B,BC)) Q:BC'>0 D
. .;Q:$P($G(^RMPR(660,BC,0)),U,10)'=RMPR("STA")
. .S GN=$P($G(^RMPR(660,BC,"AMS")),U,1)
. .S ND=$P($G(^RMPR(660,BC,1)),U,4)
. .I ND S ND=$P(^RMPR(661.1,ND,0),U,8)
. .S:ND="" ND=2
. .S:GN="" GN=BC
. .S ^TMP($J,"AG",GN,ND,BC)=B
S B=""
F S B=$O(^TMP($J,"AG",B)) Q:B'>0 D
.S BC=""
.F S BC=$O(^TMP($J,"AG",B,BC)) Q:BC'>0 D
. .Q:BC=2
. .MERGE ^TMP($J,"AGG")=^TMP($J,"AG",B)
. .S HC="",GTCST=0
. .K HCC1
. .F S HC=$O(^TMP($J,"AGG",HC)) Q:HC'>0 D
. . .S HCC=0
. . .;changes for Surgical Implants
. . .S BDC=""
. . .F BDC=1:1 S HCC=$O(^TMP($J,"AGG",HC,HCC)) Q:HCC'>0 D
. . . .S GTCST=GTCST+$P(^RMPR(660,HCC,0),U,16)
. . . .I BDC=1&(HC'=2) S HCC1=HCC
. . . .I BDC'=1 K ^TMP($J,"TT",^TMP($J,"AGG",HC,HCC),HCC)
. . . .I HC=2 K ^TMP($J,"TT",^TMP($J,"AGG",HC,HCC),HCC)
. .I $G(HCC1) S $P(^TMP($J,"TT",^TMP($J,"AGG",1,HCC1),HCC1),U,3)=GTCST K HCC1
. .K GTCST,^TMP($J,"AGG")
K ^TMP($J,"AG"),BDC
S B=0,RC=1
F S B=$O(^TMP($J,"TT",B)) Q:B'>0 D
.S RK=0
.F S RK=$O(^TMP($J,"TT",B,RK)) Q:RK'>0 D
. .Q:$D(^RMPO(665.72,"AC",RK))
. .S ^TMP($J,"RMPRC",RC)=RK
. .I $P(^TMP($J,"TT",B,RK),U,3) S $P(^TMP($J,"RMPRC",RC),U,3)=$P(^TMP($J,"TT",B,RK),U,3)
. .S RC=RC+1
S RK=0,RZ=0
K ^TMP($J,"TT"),B
;
G:'$D(^TMP($J,"RMPRC")) END
;
DIS ;format data string - only HISA
S RC=""
S RK=0
F S RK=$O(^TMP($J,"RMPRC",RK)) Q:RK="" D
.S AN=+^TMP($J,"RMPRC",RK)
.S Y=^RMPR(660,AN,0)
.D PRT
;
END ;I RC=0 S ^TMP($J,"RMPRB",0)="NOTHING TO REPORT" G EXIT
;
;
EXIT ;common exit point
K ^TMP($J,"RMPRC")
;pass to broker
;S RESULT=$NA(^TMP($J))
M RESULTS=^TMP($J,"RMPRB")
I '$D(RESULTS) S RESULTS(0)="NOTHING TO REPORT"
K I,J,L,R0,RA
Q
;
Q
PRT S DATE=$P(Y,U,3),TYPE=$P(Y,U,6),QTY=$P(Y,U,7)
S VEN=$P(Y,U,9),TRANS=$P(Y,U,4),STA=$P(Y,U,10),SN=$P(Y,U,11)
S DEL=$P(Y,U,12)
S CST=$S($P(Y,U,16)'="":$P(Y,U,16),$D(^RMPR(660,AN,"LB")):$P(^RMPR(660,AN,"LB"),U,9),1:"")
;lab source of procurement
I $D(^RMPR(660,AN,"LB")) S RMPRLPRO=$P(^("LB"),U,3) D
.I RMPRLPRO="O" S RMPRLPRO="ORTHOTIC" Q
.I RMPRLPRO="R" S RMPRLPRO="RESTORATION" Q
.I RMPRLPRO="S" S RMPRLPRO="SHOE" Q
.I RMPRLPRO="W" S RMPRLPRO="WHEELCHAIR" Q
.I RMPRLPRO="N" S RMPRLPRO="FOOT CENTER" Q
.I RMPRLPRO="D" S RMPRLPRO="DDC" Q
;form requested on
S FRM=$P(Y,U,13),REM=$P(Y,U,18)
S DATE=$E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_$E(DATE,2,3)
S TYPE=$S(TYPE="":"",$D(^RMPR(661,TYPE,0)):$P(^(0),U,1),1:""),AMIS=$P(Y,U,15),VEN=$S(VEN="":"",$D(^PRC(440,VEN,0)):$P(^(0),U,1),1:"")
I $D(^RMPR(660.1,"AC",AN)),$P(^RMPR(660.1,$O(^RMPR(660.1,"AC",AN,0)),0),U,11)]"" S AMIS=AMIS_"+"
S TRANS=$S(TRANS]"":TRANS,1:""),TRANS1="" S:TRANS="X" TRANS1=TRANS,TRANS=""
S DEL=$E(DEL,4,5)_"/"_$E(DEL,6,7)_"/"_$E(DEL,2,3) S:DEL="//" DEL=""
;
;set results array
;
S ITEM=$S(TYPE'="":$P(^PRC(441,TYPE,0),U,2),$P(Y,U,26)="D":"DELIVERY",$P(Y,U,26)="P":"PICKUP",$P(Y,U,17):"SHIPPING",1:"")
;
S HCPCS=$P($G(^RMPR(660,$P(^TMP($J,"RMPRC",RK),U,1),1)),U,4) Q:HCPCS=""
Q:$P($G(^RMPR(661.1,HCPCS,0)),U,2)'["HISA"
S HCPCS=$P($G(^RMPR(661.1,HCPCS,0)),U)
Q:STA=""
S ^TMP($J,"RMPRB",RK)=$P(^TMP($J,"RMPRC",RK),U,1)_U_DATE_U_QTY_U_ITEM
S ^TMP($J,"RMPRB",RK)=^TMP($J,"RMPRB",RK)_U_HCPCS_U_TRANS_TRANS1
;
;display source of procurement for 2529-3 under vendor header
I $D(RMPRLPRO) S ^TMP($J,"RMPRB",RK)=^TMP($J,"RMPRB",RK)_U_RMPRLPRO
I '$D(RMPRLPRO),VEN'="" S ^TMP($J,"RMPRB",RK)=^TMP($J,"RMPRB",RK)_U_$E(VEN,1,10)
K RMPRLPRO
;
S ^TMP($J,"RMPRB",RK)=^TMP($J,"RMPRB",RK)_U_$P($G(^DIC(4,STA,99)),U,1)_U_SN_U_DEL
I $P(^TMP($J,"RMPRC",RK),U,3) S CST=$P(^TMP($J,"RMPRC",RK),U,3)
S COST=$J($FN($S(CST'="":CST,$P(Y,U,17):$P(Y,U,17),1:""),"T",2),9)
;
S ^TMP($J,"RMPRB",RK)=^TMP($J,"RMPRB",RK)_U_COST_U_REM
;
I $P(^TMP($J,"RMPRC",RK),U,2)="" S $P(^TMP($J,"RMPRC",RK),U,2)=RZ
;
Q
;END
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR9S7 4409 printed Sep 23, 2025@20:09:59 Page 2
RMPR9S7 ;HOIFO/HNC - GUI 2319 TAB 7 HISA TRANSACTIONS LIST ;9/10/02 08:43
+1 ;;3.0;PROSTHETICS;**59,160**;Feb 09, 1996;Build 14
+2 ;
+3 QUIT
A1(IEN) GOTO A2
EN(RESULTS,IEN) ;broker
A2 SET (RA,AN,ANS,RK,RZ)=0
KILL ^TMP($JOB,"TT"),^TMP($JOB,"AG"),IT
+1 KILL ^TMP($JOB,"RMPRB")
+2 KILL ^TMP($JOB,"RMPRC")
+3 ;IT IS RESULTS
+4 ;0;2 DFN in 668
+5 SET RMPRDFN=$PIECE($GET(^RMPR(668,IEN,0)),U,2)
+6 IF RMPRDFN=""
SET ^TMP($JOB,"RMPRB",1)="PATIENT NOT KNOWN"
QUIT
+7 MERGE ^TMP($JOB,"TT")=^RMPR(660,"AC",RMPRDFN)
+8 SET B=0
+9 FOR
SET B=$ORDER(^TMP($JOB,"TT",B))
if B'>0
QUIT
Begin DoDot:1
+10 SET BC=0
+11 FOR
SET BC=$ORDER(^TMP($JOB,"TT",B,BC))
if BC'>0
QUIT
Begin DoDot:2
+12 ;Q:$P($G(^RMPR(660,BC,0)),U,10)'=RMPR("STA")
+13 SET GN=$PIECE($GET(^RMPR(660,BC,"AMS")),U,1)
+14 SET ND=$PIECE($GET(^RMPR(660,BC,1)),U,4)
+15 IF ND
SET ND=$PIECE(^RMPR(661.1,ND,0),U,8)
+16 if ND=""
SET ND=2
+17 if GN=""
SET GN=BC
+18 SET ^TMP($JOB,"AG",GN,ND,BC)=B
End DoDot:2
End DoDot:1
+19 SET B=""
+20 FOR
SET B=$ORDER(^TMP($JOB,"AG",B))
if B'>0
QUIT
Begin DoDot:1
+21 SET BC=""
+22 FOR
SET BC=$ORDER(^TMP($JOB,"AG",B,BC))
if BC'>0
QUIT
Begin DoDot:2
+23 if BC=2
QUIT
+24 MERGE ^TMP($JOB,"AGG")=^TMP($JOB,"AG",B)
+25 SET HC=""
SET GTCST=0
+26 KILL HCC1
+27 FOR
SET HC=$ORDER(^TMP($JOB,"AGG",HC))
if HC'>0
QUIT
Begin DoDot:3
+28 SET HCC=0
+29 ;changes for Surgical Implants
+30 SET BDC=""
+31 FOR BDC=1:1
SET HCC=$ORDER(^TMP($JOB,"AGG",HC,HCC))
if HCC'>0
QUIT
Begin DoDot:4
+32 SET GTCST=GTCST+$PIECE(^RMPR(660,HCC,0),U,16)
+33 IF BDC=1&(HC'=2)
SET HCC1=HCC
+34 IF BDC'=1
KILL ^TMP($JOB,"TT",^TMP($JOB,"AGG",HC,HCC),HCC)
+35 IF HC=2
KILL ^TMP($JOB,"TT",^TMP($JOB,"AGG",HC,HCC),HCC)
End DoDot:4
End DoDot:3
+36 IF $GET(HCC1)
SET $PIECE(^TMP($JOB,"TT",^TMP($JOB,"AGG",1,HCC1),HCC1),U,3)=GTCST
KILL HCC1
+37 KILL GTCST,^TMP($JOB,"AGG")
End DoDot:2
End DoDot:1
+38 KILL ^TMP($JOB,"AG"),BDC
+39 SET B=0
SET RC=1
+40 FOR
SET B=$ORDER(^TMP($JOB,"TT",B))
if B'>0
QUIT
Begin DoDot:1
+41 SET RK=0
+42 FOR
SET RK=$ORDER(^TMP($JOB,"TT",B,RK))
if RK'>0
QUIT
Begin DoDot:2
+43 if $DATA(^RMPO(665.72,"AC",RK))
QUIT
+44 SET ^TMP($JOB,"RMPRC",RC)=RK
+45 IF $PIECE(^TMP($JOB,"TT",B,RK),U,3)
SET $PIECE(^TMP($JOB,"RMPRC",RC),U,3)=$PIECE(^TMP($JOB,"TT",B,RK),U,3)
+46 SET RC=RC+1
End DoDot:2
End DoDot:1
+47 SET RK=0
SET RZ=0
+48 KILL ^TMP($JOB,"TT"),B
+49 ;
+50 if '$DATA(^TMP($JOB,"RMPRC"))
GOTO END
+51 ;
DIS ;format data string - only HISA
+1 SET RC=""
+2 SET RK=0
+3 FOR
SET RK=$ORDER(^TMP($JOB,"RMPRC",RK))
if RK=""
QUIT
Begin DoDot:1
+4 SET AN=+^TMP($JOB,"RMPRC",RK)
+5 SET Y=^RMPR(660,AN,0)
+6 DO PRT
End DoDot:1
+7 ;
END ;I RC=0 S ^TMP($J,"RMPRB",0)="NOTHING TO REPORT" G EXIT
+1 ;
+2 ;
EXIT ;common exit point
+1 KILL ^TMP($JOB,"RMPRC")
+2 ;pass to broker
+3 ;S RESULT=$NA(^TMP($J))
+4 MERGE RESULTS=^TMP($JOB,"RMPRB")
+5 IF '$DATA(RESULTS)
SET RESULTS(0)="NOTHING TO REPORT"
+6 KILL I,J,L,R0,RA
+7 QUIT
+8 ;
+9 QUIT
PRT SET DATE=$PIECE(Y,U,3)
SET TYPE=$PIECE(Y,U,6)
SET QTY=$PIECE(Y,U,7)
+1 SET VEN=$PIECE(Y,U,9)
SET TRANS=$PIECE(Y,U,4)
SET STA=$PIECE(Y,U,10)
SET SN=$PIECE(Y,U,11)
+2 SET DEL=$PIECE(Y,U,12)
+3 SET CST=$SELECT($PIECE(Y,U,16)'="":$PIECE(Y,U,16),$DATA(^RMPR(660,AN,"LB")):$PIECE(^RMPR(660,AN,"LB"),U,9),1:"")
+4 ;lab source of procurement
+5 IF $DATA(^RMPR(660,AN,"LB"))
SET RMPRLPRO=$PIECE(^("LB"),U,3)
Begin DoDot:1
+6 IF RMPRLPRO="O"
SET RMPRLPRO="ORTHOTIC"
QUIT
+7 IF RMPRLPRO="R"
SET RMPRLPRO="RESTORATION"
QUIT
+8 IF RMPRLPRO="S"
SET RMPRLPRO="SHOE"
QUIT
+9 IF RMPRLPRO="W"
SET RMPRLPRO="WHEELCHAIR"
QUIT
+10 IF RMPRLPRO="N"
SET RMPRLPRO="FOOT CENTER"
QUIT
+11 IF RMPRLPRO="D"
SET RMPRLPRO="DDC"
QUIT
End DoDot:1
+12 ;form requested on
+13 SET FRM=$PIECE(Y,U,13)
SET REM=$PIECE(Y,U,18)
+14 SET DATE=$EXTRACT(DATE,4,5)_"/"_$EXTRACT(DATE,6,7)_"/"_$EXTRACT(DATE,2,3)
+15 SET TYPE=$SELECT(TYPE="":"",$DATA(^RMPR(661,TYPE,0)):$PIECE(^(0),U,1),1:"")
SET AMIS=$PIECE(Y,U,15)
SET VEN=$SELECT(VEN="":"",$DATA(^PRC(440,VEN,0)):$PIECE(^(0),U,1),1:"")
+16 IF $DATA(^RMPR(660.1,"AC",AN))
IF $PIECE(^RMPR(660.1,$ORDER(^RMPR(660.1,"AC",AN,0)),0),U,11)]""
SET AMIS=AMIS_"+"
+17 SET TRANS=$SELECT(TRANS]"":TRANS,1:"")
SET TRANS1=""
if TRANS="X"
SET TRANS1=TRANS
SET TRANS=""
+18 SET DEL=$EXTRACT(DEL,4,5)_"/"_$EXTRACT(DEL,6,7)_"/"_$EXTRACT(DEL,2,3)
if DEL="//"
SET DEL=""
+19 ;
+20 ;set results array
+21 ;
+22 SET ITEM=$SELECT(TYPE'="":$PIECE(^PRC(441,TYPE,0),U,2),$PIECE(Y,U,26)="D":"DELIVERY",$PIECE(Y,U,26)="P":"PICKUP",$PIECE(Y,U,17):"SHIPPING",1:"")
+23 ;
+24 SET HCPCS=$PIECE($GET(^RMPR(660,$PIECE(^TMP($JOB,"RMPRC",RK),U,1),1)),U,4)
if HCPCS=""
QUIT
+25 if $PIECE($GET(^RMPR(661.1,HCPCS,0)),U,2)'["HISA"
QUIT
+26 SET HCPCS=$PIECE($GET(^RMPR(661.1,HCPCS,0)),U)
+27 if STA=""
QUIT
+28 SET ^TMP($JOB,"RMPRB",RK)=$PIECE(^TMP($JOB,"RMPRC",RK),U,1)_U_DATE_U_QTY_U_ITEM
+29 SET ^TMP($JOB,"RMPRB",RK)=^TMP($JOB,"RMPRB",RK)_U_HCPCS_U_TRANS_TRANS1
+30 ;
+31 ;display source of procurement for 2529-3 under vendor header
+32 IF $DATA(RMPRLPRO)
SET ^TMP($JOB,"RMPRB",RK)=^TMP($JOB,"RMPRB",RK)_U_RMPRLPRO
+33 IF '$DATA(RMPRLPRO)
IF VEN'=""
SET ^TMP($JOB,"RMPRB",RK)=^TMP($JOB,"RMPRB",RK)_U_$EXTRACT(VEN,1,10)
+34 KILL RMPRLPRO
+35 ;
+36 SET ^TMP($JOB,"RMPRB",RK)=^TMP($JOB,"RMPRB",RK)_U_$PIECE($GET(^DIC(4,STA,99)),U,1)_U_SN_U_DEL
+37 IF $PIECE(^TMP($JOB,"RMPRC",RK),U,3)
SET CST=$PIECE(^TMP($JOB,"RMPRC",RK),U,3)
+38 SET COST=$JUSTIFY($FNUMBER($SELECT(CST'="":CST,$PIECE(Y,U,17):$PIECE(Y,U,17),1:""),"T",2),9)
+39 ;
+40 SET ^TMP($JOB,"RMPRB",RK)=^TMP($JOB,"RMPRB",RK)_U_COST_U_REM
+41 ;
+42 IF $PIECE(^TMP($JOB,"RMPRC",RK),U,2)=""
SET $PIECE(^TMP($JOB,"RMPRC",RK),U,2)=RZ
+43 ;
+44 QUIT
+45 ;END
