- RMPRPAT2 ;PHX/RFM/JLT/HNC-DISPLAY PATIENT ITEM ACTIVITY ;10/19/1993
- ;;3.0;PROSTHETICS;**32,34,29,44,99,75,137,146,162**;Feb 09, 1996;Build 5
- N BDAT,HITM
- D HDR N RMPRMERG S RMPRMERG=0
- S (RA,AN,ANS,RK,RZ)=0 K ^TMP($J,"TT"),^TMP($J,"AG"),IT
- MERGE ^TMP($J,"TT")=^RMPR(660,"AC",RMPRDFN)
- ;Check for merged accounts
- I $D(^XDRM("B",RMPRDFN_";DPT(")) D
- . S RMPRMERG=$O(^XDRM("B",RMPRDFN_";DPT(",RMPRMERG)) Q:RMPRMERG=""
- . S RMPRMERG=+^XDRM(RMPRMERG,0) Q:RMPRMERG=0
- . MERGE ^TMP($J,"TT")=^RMPR(660,"AC",RMPRMERG)
- 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=0 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),^TMP($J,"TTT",B,HITM,HITM)=HITM
- . . .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 S ^TMP($J,"TTT",B,HITM,ITM)=HITM 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 IT(RC)=RK
- . .I $P(^TMP($J,"TT",B,RK),U,3) S $P(IT(RC),U,3)=$P(^TMP($J,"TT",B,RK),U,3)
- . .S RC=RC+1
- S RK=0,RZ=0
- K B,^TMP($J,"TT")
- ;
- G:'$D(IT) END
- DIS ;DISPLAY APPLIANCES OR REPAIRS
- I $G(RK)="" S RK="",RC=""
- I (RK+1'>RC)&($G(IT(RK+1))) S RK=RK+1 S AN=+IT(RK),Y=$G(^RMPR(660,AN,0)) G:Y="" EXITD D PRT,OVER:((IOSL-4)<$Y) G:'$D(ANS)!(ANS=U)!($D(DUOUT))!($D(DTOUT)) EXIT G DIS
- END I RC=0 W !,"No Appliances or Repairs exist for this veteran!",!! H 3 G EXIT
- ;
- I RC>0 W !!,"End of Appliance/Repair records for this veteran!" D OVER I $G(RK)+1'>$G(RC)&($G(IT($G(RK)+1))) D DIS
- ;
- EXIT K I,J,L,R0,IT,RA,AMIS,AN,CST,DEL,FL,FRM,ITM,PAGE,QTY,RC,RK,REM
- K RMPRCNUM,RZ,SN,TRANS,TRANS1,TYPE,VEN
- K ^TMP($J,"TTT")
- Q:'$D(RMPRDFN)
- W !
- I $D(DUOUT)!($D(DTOUT)) G ASK1^RMPRPAT
- S FL=4 G ASK2^RMPRPAT
- Q
- EXITD W !!,"Appliance/Repair record was deleted during view for this veteran",!,"...Enter 'return' to continue." R TYPE:20
- G EXIT
- 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=$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(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=""
- W !,RK,". ",DATE,?13,QTY,?17
- ;W AMIS_$S(TYPE'="":$E($P(^PRC(441,TYPE,0),U,2),1,10),$P(Y,U,26)="D":"DELIVERY",$P(Y,U,26)="P":"PICKUP",$P(Y,U,17):"SHIPPING",1:"")
- W AMIS_$S(TYPE'="":$E($P($G(^RMPR(661.1,TYPE,0)),U,2),1,10),$P(Y,U,26)="D":"DELIVERY",$P(Y,U,26)="P":"PICKUP",$P(Y,U,17):"SHIPPING",1:"")
- ;historical item
- I TYPE=""&($D(^RMPR(660,$P(IT(RK),U,1),"HST"))) W $E($P(^("HST"),U,1),1,10)
- W ?30,TRANS,?31,TRANS1
- ;display source of procurement for 2529-3 under vendor header
- I $D(RMPRLPRO) W ?33,RMPRLPRO
- ;I '$D(RMPRLPRO),VEN'="" W ?33,$E(VEN,1,10)
- I VEN'="" W ?33,$E(VEN,1,10)
- K RMPRLPRO
- ;historical vendor
- W:$D(^RMPR(660,$P(IT(RK),U,1),"HST")) $E($P(^("HST"),U,3),1,10)
- W:STA'="" ?45,$P(^DIC(4,STA,99),U,1)
- W ?50,$E(SN,1,9),?60,DEL
- I $P(IT(RK),U,3) S CST=$P(IT(RK),U,3)
- W ?71,$J($FN($S(CST'="":CST,$P(Y,U,17):$P(Y,U,17),1:""),"T",2),9)
- W:REM]"" !,?3,REM
- I $P(IT(RK),U,2)="" S $P(IT(RK),U,2)=RZ
- Q
- OVER ;
- N ANS
- S RZ=RK W !,"+=Turned-In *=Historical Data I=Initial X=Repair S=Spare R=Replacement",!,"Enter 1-",RK," to show full entry, '^' to exit or `return` to continue. " R ANS:DTIME S:'$T ANS="^"
- I ANS="^^" S ANS="^" S DUOUT=1 Q ;modified escape as it left a DO loop hanging due to GOTO, patch RMPR*3.0*162
- I ANS="^" S DUOUT=1 Q ;modified escape as it left a DO loop hanging due to GOTO, patch RMPR*3.0*162
- I ANS="",RK+1'>RC&($G(IT(RK+1))) D HDR Q
- I ANS="" Q
- I ANS'?1N.N!(ANS>RK)!(+ANS=0)!(+ANS'=ANS) W $C(7),!," Must be between 1 and ",RK," to be valid" G OVER
- I ANS>0,(ANS<(RK+1)) S AN=ANS,RZ=RK D ^RMPRPAT3
- S RK=$P(IT(ANS),U,2)
- Q
- HDR ;Print Header, Screen 4
- W @IOF
- S PAGE=3
- W !,$E(RMPRNAM,1,20),?23,"SSN: "
- W $E(RMPRSSN,1,3)_"-"_$E(RMPRSSN,4,5)_"-"_$E(RMPRSSN,6,10)
- W ?42,"DOB: "
- S Y=RMPRDOB X ^DD("DD") W Y K Y
- W ?61,"CLAIM# ",$G(RMPRCNUM)
- W !?4,"Date",?12,"Qty",?19,"HCPCS",?28,"Type",?34,"Vendor",?45,"Sta",?50,"Serial",?58,"Delivery Date",?72,"Tot Cost"
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPAT2 5705 printed Feb 19, 2025@00:02:06 Page 2
- RMPRPAT2 ;PHX/RFM/JLT/HNC-DISPLAY PATIENT ITEM ACTIVITY ;10/19/1993
- +1 ;;3.0;PROSTHETICS;**32,34,29,44,99,75,137,146,162**;Feb 09, 1996;Build 5
- +2 NEW BDAT,HITM
- +3 DO HDR
- NEW RMPRMERG
- SET RMPRMERG=0
- +4 SET (RA,AN,ANS,RK,RZ)=0
- KILL ^TMP($JOB,"TT"),^TMP($JOB,"AG"),IT
- +5 MERGE ^TMP($JOB,"TT")=^RMPR(660,"AC",RMPRDFN)
- +6 ;Check for merged accounts
- +7 IF $DATA(^XDRM("B",RMPRDFN_";DPT("))
- Begin DoDot:1
- +8 SET RMPRMERG=$ORDER(^XDRM("B",RMPRDFN_";DPT(",RMPRMERG))
- if RMPRMERG=""
- QUIT
- +9 SET RMPRMERG=+^XDRM(RMPRMERG,0)
- if RMPRMERG=0
- QUIT
- +10 MERGE ^TMP($JOB,"TT")=^RMPR(660,"AC",RMPRMERG)
- End DoDot:1
- +11 SET B=0
- +12 FOR
- SET B=$ORDER(^TMP($JOB,"TT",B))
- if B'>0
- QUIT
- Begin DoDot:1
- +13 SET BC=0
- +14 FOR
- SET BC=$ORDER(^TMP($JOB,"TT",B,BC))
- if BC'>0
- QUIT
- Begin DoDot:2
- +15 if $PIECE($GET(^RMPR(660,BC,0)),U,10)'=RMPR("STA")
- QUIT
- +16 SET GN=$PIECE($GET(^RMPR(660,BC,"AMS")),U,1)
- +17 SET ND=$PIECE($GET(^RMPR(660,BC,1)),U,4)
- +18 IF ND
- SET ND=$PIECE(^RMPR(661.1,ND,0),U,8)
- +19 if ND=""
- SET ND=2
- +20 if GN=""
- SET GN=BC
- +21 ;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
- +22 ;COMBINE ITEMS FOR CALC FLAG
- +23 ;modified linked grouper structure determination in patch RMPR*3.0*162
- +24 SET B=""
- +25 FOR
- SET B=$ORDER(^TMP($JOB,"AG",B))
- SET ITM=0
- SET HITM=0
- if +B=0
- QUIT
- Begin DoDot:1
- +26 FOR
- SET ITM=$ORDER(^TMP($JOB,"AG",B,ITM))
- SET BC=0
- if +ITM=0
- QUIT
- Begin DoDot:2
- +27 FOR
- SET BC=$ORDER(^TMP($JOB,"AG",B,ITM,BC))
- if +BC=0
- QUIT
- Begin DoDot:3
- +28 IF $PIECE($GET(^RMPR(660,ITM,0)),U,17)
- QUIT
- +29 IF HITM=0
- IF BC=2
- QUIT
- +30 IF BC=1
- SET HITM=ITM
- SET BDAT=^TMP($JOB,"AG",B,ITM,BC)
- SET ^TMP($JOB,"TTT",B,HITM,HITM)=HITM
- +31 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)
- +32 IF BC=2
- SET ^TMP($JOB,"TTT",B,HITM,ITM)=HITM
- KILL ^TMP($JOB,"TT",BDAT,ITM)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +33 KILL ^TMP($JOB,"AG"),BDC
- +34 SET B=0
- SET RC=1
- +35 FOR
- SET B=$ORDER(^TMP($JOB,"TT",B))
- if B'>0
- QUIT
- Begin DoDot:1
- +36 SET RK=0
- +37 FOR
- SET RK=$ORDER(^TMP($JOB,"TT",B,RK))
- if RK'>0
- QUIT
- Begin DoDot:2
- +38 if $DATA(^RMPO(665.72,"AC",RK))
- QUIT
- +39 SET IT(RC)=RK
- +40 IF $PIECE(^TMP($JOB,"TT",B,RK),U,3)
- SET $PIECE(IT(RC),U,3)=$PIECE(^TMP($JOB,"TT",B,RK),U,3)
- +41 SET RC=RC+1
- End DoDot:2
- End DoDot:1
- +42 SET RK=0
- SET RZ=0
- +43 KILL B,^TMP($JOB,"TT")
- +44 ;
- +45 if '$DATA(IT)
- GOTO END
- DIS ;DISPLAY APPLIANCES OR REPAIRS
- +1 IF $GET(RK)=""
- SET RK=""
- SET RC=""
- +2 IF (RK+1'>RC)&($GET(IT(RK+1)))
- SET RK=RK+1
- SET AN=+IT(RK)
- SET Y=$GET(^RMPR(660,AN,0))
- if Y=""
- GOTO EXITD
- DO PRT
- if ((IOSL-4)<$Y)
- DO OVER
- if '$DATA(ANS)!(ANS=U)!($DATA(DUOUT))!($DATA(DTOUT))
- GOTO EXIT
- GOTO DIS
- END IF RC=0
- WRITE !,"No Appliances or Repairs exist for this veteran!",!!
- HANG 3
- GOTO EXIT
- +1 ;
- +2 IF RC>0
- WRITE !!,"End of Appliance/Repair records for this veteran!"
- DO OVER
- IF $GET(RK)+1'>$GET(RC)&($GET(IT($GET(RK)+1)))
- DO DIS
- +3 ;
- EXIT KILL I,J,L,R0,IT,RA,AMIS,AN,CST,DEL,FL,FRM,ITM,PAGE,QTY,RC,RK,REM
- +1 KILL RMPRCNUM,RZ,SN,TRANS,TRANS1,TYPE,VEN
- +2 KILL ^TMP($JOB,"TTT")
- +3 if '$DATA(RMPRDFN)
- QUIT
- +4 WRITE !
- +5 IF $DATA(DUOUT)!($DATA(DTOUT))
- GOTO ASK1^RMPRPAT
- +6 SET FL=4
- GOTO ASK2^RMPRPAT
- +7 QUIT
- EXITD WRITE !!,"Appliance/Repair record was deleted during view for this veteran",!,"...Enter 'return' to continue."
- READ TYPE:20
- +1 GOTO EXIT
- 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=$PIECE($GET(^RMPR(660,AN,1)),U,4)
- +16 ;S TYPE=$S(TYPE="":"",$D(^RMPR(661,TYPE,0)):$P(^(0),U,1),1:"")
- +17 SET AMIS=$PIECE(Y,U,15)
- SET VEN=$SELECT(VEN="":"",$DATA(^PRC(440,VEN,0)):$PIECE(^(0),U,1),1:"")
- +18 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_"+"
- +19 SET TRANS=$SELECT(TRANS]"":TRANS,1:"")
- SET TRANS1=""
- if TRANS="X"
- SET TRANS1=TRANS
- SET TRANS=""
- +20 SET DEL=$EXTRACT(DEL,4,5)_"/"_$EXTRACT(DEL,6,7)_"/"_$EXTRACT(DEL,2,3)
- if DEL="//"
- SET DEL=""
- +21 WRITE !,RK,". ",DATE,?13,QTY,?17
- +22 ;W AMIS_$S(TYPE'="":$E($P(^PRC(441,TYPE,0),U,2),1,10),$P(Y,U,26)="D":"DELIVERY",$P(Y,U,26)="P":"PICKUP",$P(Y,U,17):"SHIPPING",1:"")
- +23 WRITE AMIS_$SELECT(TYPE'="":$EXTRACT($PIECE($GET(^RMPR(661.1,TYPE,0)),U,2),1,10),$PIECE(Y,U,26)="D":"DELIVERY",$PIECE(Y,U,26)="P":"PICKUP",$PIECE(Y,U,17):"SHIPPING",1:"")
- +24 ;historical item
- +25 IF TYPE=""&($DATA(^RMPR(660,$PIECE(IT(RK),U,1),"HST")))
- WRITE $EXTRACT($PIECE(^("HST"),U,1),1,10)
- +26 WRITE ?30,TRANS,?31,TRANS1
- +27 ;display source of procurement for 2529-3 under vendor header
- +28 IF $DATA(RMPRLPRO)
- WRITE ?33,RMPRLPRO
- +29 ;I '$D(RMPRLPRO),VEN'="" W ?33,$E(VEN,1,10)
- +30 IF VEN'=""
- WRITE ?33,$EXTRACT(VEN,1,10)
- +31 KILL RMPRLPRO
- +32 ;historical vendor
- +33 if $DATA(^RMPR(660,$PIECE(IT(RK),U,1),"HST"))
- WRITE $EXTRACT($PIECE(^("HST"),U,3),1,10)
- +34 if STA'=""
- WRITE ?45,$PIECE(^DIC(4,STA,99),U,1)
- +35 WRITE ?50,$EXTRACT(SN,1,9),?60,DEL
- +36 IF $PIECE(IT(RK),U,3)
- SET CST=$PIECE(IT(RK),U,3)
- +37 WRITE ?71,$JUSTIFY($FNUMBER($SELECT(CST'="":CST,$PIECE(Y,U,17):$PIECE(Y,U,17),1:""),"T",2),9)
- +38 if REM]""
- WRITE !,?3,REM
- +39 IF $PIECE(IT(RK),U,2)=""
- SET $PIECE(IT(RK),U,2)=RZ
- +40 QUIT
- OVER ;
- +1 NEW ANS
- +2 SET RZ=RK
- WRITE !,"+=Turned-In *=Historical Data I=Initial X=Repair S=Spare R=Replacement",!,"Enter 1-",RK," to show full entry, '^' to exit or `return` to continue. "
- READ ANS:DTIME
- if '$TEST
- SET ANS="^"
- +3 ;modified escape as it left a DO loop hanging due to GOTO, patch RMPR*3.0*162
- IF ANS="^^"
- SET ANS="^"
- SET DUOUT=1
- QUIT
- +4 ;modified escape as it left a DO loop hanging due to GOTO, patch RMPR*3.0*162
- IF ANS="^"
- SET DUOUT=1
- QUIT
- +5 IF ANS=""
- IF RK+1'>RC&($GET(IT(RK+1)))
- DO HDR
- QUIT
- +6 IF ANS=""
- QUIT
- +7 IF ANS'?1N.N!(ANS>RK)!(+ANS=0)!(+ANS'=ANS)
- WRITE $CHAR(7),!," Must be between 1 and ",RK," to be valid"
- GOTO OVER
- +8 IF ANS>0
- IF (ANS<(RK+1))
- SET AN=ANS
- SET RZ=RK
- DO ^RMPRPAT3
- +9 SET RK=$PIECE(IT(ANS),U,2)
- +10 QUIT
- HDR ;Print Header, Screen 4
- +1 WRITE @IOF
- +2 SET PAGE=3
- +3 WRITE !,$EXTRACT(RMPRNAM,1,20),?23,"SSN: "
- +4 WRITE $EXTRACT(RMPRSSN,1,3)_"-"_$EXTRACT(RMPRSSN,4,5)_"-"_$EXTRACT(RMPRSSN,6,10)
- +5 WRITE ?42,"DOB: "
- +6 SET Y=RMPRDOB
- XECUTE ^DD("DD")
- WRITE Y
- KILL Y
- +7 WRITE ?61,"CLAIM# ",$GET(RMPRCNUM)
- +8 WRITE !?4,"Date",?12,"Qty",?19,"HCPCS",?28,"Type",?34,"Vendor",?45,"Sta",?50,"Serial",?58,"Delivery Date",?72,"Tot Cost"
- +9 QUIT