RMPR9S4 ;HOIFO/HNC - GUI 2319 ITEM TRANSACTIONS LIST ;9/10/02 08:42
;;3.0;PROSTHETICS;**59,99,90,75,162**;Feb 09, 1996;Build 5
;IEN = INTERNAL ENTRY NUMBER OF FILE 668
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"),RMPRLPRO
;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,BC,ND)=B ;set linked grouper counter structure differently in array;RMPR*3.0*162
;COMBINE ITEMS FOR CALC FLAG
;modified linked grouper structure determination in patch RMPR*3.0*162
S B=""
F S B=$O(^TMP($J,"AG",B)),ITM=0,HITM=0 Q:B=""!(B]"@") D
.F S ITM=$O(^TMP($J,"AG",B,ITM)),BC=0 Q:+ITM=0 D
. .F S BC=$O(^TMP($J,"AG",B,ITM,BC)) Q:+BC=0 D
. . .I $P($G(^RMPR(660,ITM,0)),U,17) Q
. . .I HITM=0,BC=2 Q
. . .I BC=1 S HITM=ITM,BDAT=^TMP($J,"AG",B,ITM,BC)
. . .S $P(^TMP($J,"TT",BDAT,HITM),U,3)=$P(^TMP($J,"TT",BDAT,HITM),U,3)+$P($G(^RMPR(660,ITM,0)),U,16)
. . .I BC=2 K ^TMP($J,"TT",BDAT,ITM)
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 - ALL
S RC=""
S RK=0
F S RK=$O(^TMP($J,"RMPRC",RK)) Q:RK="" D
.S AN=+^TMP($J,"RMPRC",RK)
.S RMPRY=$G(^RMPR(660,AN,0))
.I RMPRY'="" D PRT
.Q
;
;
END I RC=0 S ^TMP($J,"RMPRB",1)="NOTHING TO REPORT" G EXIT
;
;
EXIT ;common exit point
;pass to broker
K ^TMP($J,"RMPRC")
;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,AMIS,AN,ANS,CST,FRM,RC,RK,RMPRDFN,RMPRNC,RZ,STA,TRANS,TRANS,TYPE,BDAT,HITM,ITM,TRANS1
Q
PRT ;
S DATE=$P(RMPRY,U,3),TYPE=$P(RMPRY,U,6),QTY=$P(RMPRY,U,7)
S VEN=$P(RMPRY,U,9),TRANS=$P(RMPRY,U,4),STA=$P(RMPRY,U,10),SN=$P(RMPRY,U,11)
S DEL=$P(RMPRY,U,12)
S CST=$S($P(RMPRY,U,16)'="":$P(RMPRY,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
.I RMPRLPRO="E" S RMPRLPRO="EYE GLASS" Q
.I RMPRLPRO="" K RMPRLPRO
;form requested on
S FRM=$P(RMPRY,U,13)
S RMPRNC=$P($G(^RMPR(660,AN,"AM")),U,2)
S DATE=$$DAT2^RMPRUTL1(DATE)
S TYPE=$P($G(^RMPR(660,AN,1)),U,4)
;S TYPE=$S(TYPE="":"",$D(^RMPR(661,TYPE,0)):$P(^(0),U,1),1:"")
S AMIS=$P(RMPRY,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 HTYPE=""
I $D(^RMPR(660,$P(^TMP($J,"RMPRC",RK),U,1),"HST")) S HTYPE=$E(^RMPR(660,$P(^TMP($J,"RMPRC",RK),U,1),"HST"),1,15)
S ITEM=AMIS_$S(TYPE'="":$P($G(^RMPR(661.1,TYPE,0)),U,2),$P(RMPRY,U,26)="D":"DELIVERY",$P(RMPRY,U,26)="P":"PICKUP",$P(RMPRY,U,17):"SHIPPING",HTYPE'="":HTYPE,1:"")
K HTYPE
;
S HCPCS=$P($G(^RMPR(660,$P(^TMP($J,"RMPRC",RK),U,1),1)),U,4)
I HCPCS'="" S HCPCS=$P($G(^RMPR(661.1,HCPCS,0)),U,1)
;
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
E S:VEN'="" ^TMP($J,"RMPRB",RK)=^TMP($J,"RMPRB",RK)_U_$E(VEN,1,10)
I VEN=""&'$D(RMPRLPRO) S:'$D(^RMPR(660,$P(^TMP($J,"RMPRC",RK),U,1),"HST")) ^TMP($J,"RMPRB",RK)=^TMP($J,"RMPRB",RK)_U_$E(VEN,1,10)
I VEN=""&'$D(RMPRLPRO) S:$D(^RMPR(660,$P(^TMP($J,"RMPRC",RK),U,1),"HST")) ^TMP($J,"RMPRB",RK)=^TMP($J,"RMPRB",RK)_U_$E($P(^RMPR(660,$P(^TMP($J,"RMPRC",RK),U,1),"HST"),U,3),1,10)
;
I STA'="" S ^TMP($J,"RMPRB",RK)=^TMP($J,"RMPRB",RK)_U_$P($G(^DIC(4,STA,99)),U,1)
I STA="" S ^TMP($J,"RMPRB",RK)=^TMP($J,"RMPRB",RK)_U_"UNKNOWN"
S ^TMP($J,"RMPRB",RK)=^TMP($J,"RMPRB",RK)_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(RMPRY,U,17):$P(RMPRY,U,17),1:""),"T",2),9)
;
S ^TMP($J,"RMPRB",RK)=^TMP($J,"RMPRB",RK)_U_COST_U_RMPRNC
;
I $P(^TMP($J,"RMPRC",RK),U,2)="" S $P(^TMP($J,"RMPRC",RK),U,2)=RZ
K DATE,QTY,ITEM,HCPSC,RMPRLPRO,VEN,SN,DEL,COST,REM
;
Q
;END
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR9S4 5255 printed Apr 09, 2024@21:39:04 Page 2
RMPR9S4 ;HOIFO/HNC - GUI 2319 ITEM TRANSACTIONS LIST ;9/10/02 08:42
+1 ;;3.0;PROSTHETICS;**59,99,90,75,162**;Feb 09, 1996;Build 5
+2 ;IEN = INTERNAL ENTRY NUMBER OF FILE 668
+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"),RMPRLPRO
+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 linked grouper counter structure differently in array;RMPR*3.0*162
SET ^TMP($JOB,"AG",GN,BC,ND)=B
End DoDot:2
End DoDot:1
+19 ;COMBINE ITEMS FOR CALC FLAG
+20 ;modified linked grouper structure determination in patch RMPR*3.0*162
+21 SET B=""
+22 FOR
SET B=$ORDER(^TMP($JOB,"AG",B))
SET ITM=0
SET HITM=0
if B=""!(B]"@")
QUIT
Begin DoDot:1
+23 FOR
SET ITM=$ORDER(^TMP($JOB,"AG",B,ITM))
SET BC=0
if +ITM=0
QUIT
Begin DoDot:2
+24 FOR
SET BC=$ORDER(^TMP($JOB,"AG",B,ITM,BC))
if +BC=0
QUIT
Begin DoDot:3
+25 IF $PIECE($GET(^RMPR(660,ITM,0)),U,17)
QUIT
+26 IF HITM=0
IF BC=2
QUIT
+27 IF BC=1
SET HITM=ITM
SET BDAT=^TMP($JOB,"AG",B,ITM,BC)
+28 SET $PIECE(^TMP($JOB,"TT",BDAT,HITM),U,3)=$PIECE(^TMP($JOB,"TT",BDAT,HITM),U,3)+$PIECE($GET(^RMPR(660,ITM,0)),U,16)
+29 IF BC=2
KILL ^TMP($JOB,"TT",BDAT,ITM)
End DoDot:3
End DoDot:2
End DoDot:1
+30 KILL ^TMP($JOB,"AG"),BDC
+31 SET B=0
SET RC=1
+32 FOR
SET B=$ORDER(^TMP($JOB,"TT",B))
if B'>0
QUIT
Begin DoDot:1
+33 SET RK=0
+34 FOR
SET RK=$ORDER(^TMP($JOB,"TT",B,RK))
if RK'>0
QUIT
Begin DoDot:2
+35 if $DATA(^RMPO(665.72,"AC",RK))
QUIT
+36 SET ^TMP($JOB,"RMPRC",RC)=RK
+37 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)
+38 SET RC=RC+1
End DoDot:2
End DoDot:1
+39 SET RK=0
SET RZ=0
+40 KILL ^TMP($JOB,"TT"),B
+41 ;
+42 if '$DATA(^TMP($JOB,"RMPRC"))
GOTO END
+43 ;
DIS ;format data string - ALL
+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 RMPRY=$GET(^RMPR(660,AN,0))
+6 IF RMPRY'=""
DO PRT
+7 QUIT
End DoDot:1
+8 ;
+9 ;
END IF RC=0
SET ^TMP($JOB,"RMPRB",1)="NOTHING TO REPORT"
GOTO EXIT
+1 ;
+2 ;
EXIT ;common exit point
+1 ;pass to broker
+2 KILL ^TMP($JOB,"RMPRC")
+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,AMIS,AN,ANS,CST,FRM,RC,RK,RMPRDFN,RMPRNC,RZ,STA,TRANS,TRANS,TYPE,BDAT,HITM,ITM,TRANS1
+7 QUIT
PRT ;
+1 SET DATE=$PIECE(RMPRY,U,3)
SET TYPE=$PIECE(RMPRY,U,6)
SET QTY=$PIECE(RMPRY,U,7)
+2 SET VEN=$PIECE(RMPRY,U,9)
SET TRANS=$PIECE(RMPRY,U,4)
SET STA=$PIECE(RMPRY,U,10)
SET SN=$PIECE(RMPRY,U,11)
+3 SET DEL=$PIECE(RMPRY,U,12)
+4 SET CST=$SELECT($PIECE(RMPRY,U,16)'="":$PIECE(RMPRY,U,16),$DATA(^RMPR(660,AN,"LB")):$PIECE(^RMPR(660,AN,"LB"),U,9),1:"")
+5 ;lab source of procurement
+6 IF $DATA(^RMPR(660,AN,"LB"))
SET RMPRLPRO=$PIECE(^("LB"),U,3)
Begin DoDot:1
+7 IF RMPRLPRO="O"
SET RMPRLPRO="ORTHOTIC"
QUIT
+8 IF RMPRLPRO="R"
SET RMPRLPRO="RESTORATION"
QUIT
+9 IF RMPRLPRO="S"
SET RMPRLPRO="SHOE"
QUIT
+10 IF RMPRLPRO="W"
SET RMPRLPRO="WHEELCHAIR"
QUIT
+11 IF RMPRLPRO="N"
SET RMPRLPRO="FOOT CENTER"
QUIT
+12 IF RMPRLPRO="D"
SET RMPRLPRO="DDC"
QUIT
+13 IF RMPRLPRO="E"
SET RMPRLPRO="EYE GLASS"
QUIT
+14 IF RMPRLPRO=""
KILL RMPRLPRO
End DoDot:1
+15 ;form requested on
+16 SET FRM=$PIECE(RMPRY,U,13)
+17 SET RMPRNC=$PIECE($GET(^RMPR(660,AN,"AM")),U,2)
+18 SET DATE=$$DAT2^RMPRUTL1(DATE)
+19 SET TYPE=$PIECE($GET(^RMPR(660,AN,1)),U,4)
+20 ;S TYPE=$S(TYPE="":"",$D(^RMPR(661,TYPE,0)):$P(^(0),U,1),1:"")
+21 SET AMIS=$PIECE(RMPRY,U,15)
SET VEN=$SELECT(VEN="":"",$DATA(^PRC(440,VEN,0)):$PIECE(^(0),U,1),1:"")
+22 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_"+"
+23 SET TRANS=$SELECT(TRANS]"":TRANS,1:"")
SET TRANS1=""
if TRANS="X"
SET TRANS1=TRANS
SET TRANS=""
+24 SET DEL=$EXTRACT(DEL,4,5)_"/"_$EXTRACT(DEL,6,7)_"/"_$EXTRACT(DEL,2,3)
if DEL="//"
SET DEL=""
+25 ;
+26 ;set results array
+27 ;
+28 SET HTYPE=""
+29 IF $DATA(^RMPR(660,$PIECE(^TMP($JOB,"RMPRC",RK),U,1),"HST"))
SET HTYPE=$EXTRACT(^RMPR(660,$PIECE(^TMP($JOB,"RMPRC",RK),U,1),"HST"),1,15)
+30 SET ITEM=AMIS_$SELECT(TYPE'="":$PIECE($GET(^RMPR(661.1,TYPE,0)),U,2),$PIECE(RMPRY,U,26)="D":"DELIVERY",$PIECE(RMPRY,U,26)="P":"PICKUP",$PIECE(RMPRY,U,17):"SHIPPING",HTYPE'="":HTYPE,1:"")
+31 KILL HTYPE
+32 ;
+33 SET HCPCS=$PIECE($GET(^RMPR(660,$PIECE(^TMP($JOB,"RMPRC",RK),U,1),1)),U,4)
+34 IF HCPCS'=""
SET HCPCS=$PIECE($GET(^RMPR(661.1,HCPCS,0)),U,1)
+35 ;
+36 SET ^TMP($JOB,"RMPRB",RK)=$PIECE(^TMP($JOB,"RMPRC",RK),U,1)_U_DATE_U_QTY_U_ITEM
+37 SET ^TMP($JOB,"RMPRB",RK)=^TMP($JOB,"RMPRB",RK)_U_HCPCS_U_TRANS_TRANS1
+38 ;
+39 ;display source of procurement for 2529-3 under vendor header
+40 IF $DATA(RMPRLPRO)
SET ^TMP($JOB,"RMPRB",RK)=^TMP($JOB,"RMPRB",RK)_U_RMPRLPRO
+41 IF '$TEST
if VEN'=""
SET ^TMP($JOB,"RMPRB",RK)=^TMP($JOB,"RMPRB",RK)_U_$EXTRACT(VEN,1,10)
+42 IF VEN=""&'$DATA(RMPRLPRO)
if '$DATA(^RMPR(660,$PIECE(^TMP($JOB,"RMPRC",RK),U,1),"HST"))
SET ^TMP($JOB,"RMPRB",RK)=^TMP($JOB,"RMPRB",RK)_U_$EXTRACT(VEN,1,10)
+43 IF VEN=""&'$DATA(RMPRLPRO)
if $DATA(^RMPR(660,$PIECE(^TMP($JOB,"RMPRC",RK),U,1),"HST"))
SET ^TMP($JOB,"RMPRB",RK)=^TMP($JOB,"RMPRB",RK)_U_$EXTRACT($PIECE(^RMPR(660,$PIECE(^TMP($JOB,"RMPRC",RK),U,1),"HST"),U,3),1,10)
+44 ;
+45 IF STA'=""
SET ^TMP($JOB,"RMPRB",RK)=^TMP($JOB,"RMPRB",RK)_U_$PIECE($GET(^DIC(4,STA,99)),U,1)
+46 IF STA=""
SET ^TMP($JOB,"RMPRB",RK)=^TMP($JOB,"RMPRB",RK)_U_"UNKNOWN"
+47 SET ^TMP($JOB,"RMPRB",RK)=^TMP($JOB,"RMPRB",RK)_U_SN_U_DEL
+48 IF $PIECE(^TMP($JOB,"RMPRC",RK),U,3)
SET CST=$PIECE(^TMP($JOB,"RMPRC",RK),U,3)
+49 SET COST=$JUSTIFY($FNUMBER($SELECT(CST'="":CST,$PIECE(RMPRY,U,17):$PIECE(RMPRY,U,17),1:""),"T",2),9)
+50 ;
+51 SET ^TMP($JOB,"RMPRB",RK)=^TMP($JOB,"RMPRB",RK)_U_COST_U_RMPRNC
+52 ;
+53 IF $PIECE(^TMP($JOB,"RMPRC",RK),U,2)=""
SET $PIECE(^TMP($JOB,"RMPRC",RK),U,2)=RZ
+54 KILL DATE,QTY,ITEM,HCPSC,RMPRLPRO,VEN,SN,DEL,COST,REM
+55 ;
+56 QUIT
+57 ;END
