- RMPRPRT1 ;PHX/HNB-CONTINUATION OF PRINT 2319 ;10/19/1993
- ;;3.0;PROSTHETICS;**10,99,137,141**;Feb 09, 1996;Build 5
- ;CALLED BY END^RMPRPRT
- ;VARIABLES REQUIRED: R5 - A STRING ARRAY HOLDING PATIENT'S PROSTHETIC
- ; DISABILITY CODE INFORMATION
- N RMPRMERG S RMPRMERG=0
- I $D(^XDRM("B",RMPRDFN_";DPT(")) D
- . S RMPRMERG=$O(^XDRM("B",RMPRDFN_";DPT(",RMPRMERG)) Q:RMPRMERG=""
- . S RMPRMERG=+^XDRM(RMPRMERG,0)
- I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT
- W !!,"PSC Issue Card: " S J=0 W !
- F I=1:1 D Q:J'>0
- .I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT
- .S J=$O(R5(5,J)) Q:J=""!(J?.A) Q:$G(J)<1
- .S L=$P(R5(5,J,0),U,1) ;S L=$P(R5(5,J,0),U,1)
- .W $E(L,4,5)_"-"_$E(L,6,7)_"-"_$E(L,2,3),?17,"Appl: ",$S($D(^RMPR(661,+$P(R5(5,J,0),U,4),0)):$E($P(^PRC(441,+$P(^(0),U),0),U,2),1,37),1:"UNKNOWN"),?66,"SN: ",$P(R5(5,J,0),U,3),!
- I I=1 W "NONE LISTED",!
- W !,"Clothing Allowance: ",!
- I $D(R5(6)),$O(R5(6,0))>0 D
- .F RI=0:0 S RI=$O(^RMPR(665,RMPRDFN,6,"B",RI)) Q:RI'>0 D
- ..S RA=$O(^RMPR(665,RMPRDFN,6,"B",RI,0))
- ..S RR5=R5(6,RA,0),RR5=RR5
- ..;D I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT
- ..W ?22,"DATE: ",$E(RR5,4,5)_"-"_$E(RR5,6,7)_"-"_$E(RR5,2,3)
- ..W " ",$S($P(RR5,U,2)["E":"ELIGIBLE",$P(RR5,U,2)["N":"NOT-ELIGIBLE",1:"")
- ..W " ",$S($P(RR5,U,3)["S":"STATIC",$P(RR5,U,3)["N":"NON-STATIC",1:"")
- ..I $P(RR5,U,5) S Y=$P(RR5,U,5) D DD^%DT W !,?22,"Date of Exam: ",Y W:$P(RR5,U,6) " Examiner: ",$E($P(^VA(200,$P(RR5,U,6),0),U,1),1,30)
- ..W !,?22,"Desc: "
- ..W $S($D(R5(6,RA,1)):$P(R5(6,RA,1),U),1:""),!
- ..I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT
- I '$D(R5(6)),$P(R5(0),U,6)="" W "NONE LISTED",!
- S RO=0
- F S RO=$O(^RMPR(667,"C",RMPRDFN,RO)) Q:RO'>0 D I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT
- .Q:$P(^RMPR(667,RO,2),U,1)=0
- .W:'$D(RMPRFLG) !,"Automobile(s):",?15,"Make",?27,"Model",?39,"Vehical ID #",?62,"Date Processed"
- .W:'$P(^RMPR(667,RO,0),U,6)'="" !?15,$E($P(^RMPR(667.2,$P(^RMPR(667,RO,0),U,6),0),U,1),1,11),?27,$E($P(^RMPR(667,RO,0),U,7),1,10),?39,$P(^RMPR(667,RO,0),U,1) S Y=$P(^RMPR(667,RO,0),U,8) D DD^%DT W ?64,Y S RMPRFLG=1
- I '$D(RMPRFLG) W !,"Automobile(s): NONE LISTED"
- W !,"Items Returned: "
- I $D(^RMPR(665,RMPRDFN,7,0)) D OLD^RMPRPAT1
- I $D(^RMPR(660.1,"C",RMPRDFN)) S RO=0 F S RO=$O(^RMPR(660.1,"C",RMPRDFN,RO)) Q:RO'>0 D WRIL^RMPRPAT1
- I '$D(^RMPR(660.1,"C",RMPRDFN)) W "NONE LISTED"
- ;W !!,"Items on loan: " I $D(^RMPR(660.1,"C",RMPRDFN)) S RO=0 F S RO=$O(^RMPR(660.1,"C",RMPRDFN,RO)) Q:RO="" D WRIL^RMPRPAT1
- W !!,"Other Data: " S J=0 F I=1:1 S J=$O(R5(4,J)) Q:J=""!(J?.A) W !?5,R5(4,J,0) I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT
- I I=1 W "NONE LISTED"
- I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT
- W !,"RECORD OF APPLIANCES/REPAIRS: " D HDRH S RC=0,(RA,AN)=""
- S RA=""
- F S RA=$O(^RMPR(660,"AC",RMPRDFN,RA)) Q:RA'>0 S AN="" F S AN=$O(^RMPR(660,"AC",RMPRDFN,RA,AN)) Q:AN'>0 S RC=RC+1,Y=^RMPR(660,AN,0) D PRT I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT
- S RA=""
- I RMPRMERG D
- . F S RA=$O(^RMPR(660,"AC",RMPRMERG,RA)) Q:RA'>0 S AN="" F S AN=$O(^RMPR(660,"AC",RMPRMERG,RA,AN)) Q:AN'>0 S RC=RC+1,Y=^RMPR(660,AN,0) D PRT I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT
- I RC=0 W !,"No Appliances or Repairs exist for this veteran!",!!
- E W !!,"End of Appliance/Repair records for this veteran!",!!," *Historical Item"
- EXIT K I,IT,J,L,RC,K,RA,AN,DATE,TYPE,QTY,VEN,TRANS,TRANS1,STA,SN,DEL,CST,FRM,REM,R0,RMPRE,RMPRFLG,RO,Y G EXIT^RMPRPRT
- HDRH W !!?4,"DATE",?13,"QTY",?17," HCPCS DESC",?29,"N R ",?33,"VENDOR",?45,"STA",?50,"SERIAL NBR",?62,"DELIVERED",?72,"COST",!
- F L=1:1:79 W "-"
- Q
- PRT S DATE=$P(Y,U,3),TYPE=$P(Y,U,6),QTY=$P(Y,U,7),VEN=$P(Y,U,9),TRANS=$P(Y,U,4),STA=$P(Y,U,10),SN=$P(Y,U,11),DEL=$P(Y,U,12),AMIS=$P(Y,U,15)
- ;include 2529-3 data
- S CST=$S($P(Y,U,16)'="":$P(Y,U,16),$D(^RMPR(660,AN,"LB")):$P(^RMPR(660,AN,"LB"),U,9),1:"")
- ;vendor 2529-3
- 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="RESTROATION" 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
- S FRM=$P(Y,U,13),REM=$P(Y,U,18),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:"")
- S TYPE=$P($G(^RMPR(660,AN,1)),U,4)
- S VEN=$S(VEN="":"",$D(^PRC(440,VEN,0)):$P(^(0),U,1),1:"")
- 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 !,RC,". ",DATE,?13,QTY,?17
- 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:"")
- ;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:"")
- ;I TYPE=""&($D(^RMPR(660,$P(IT(RK),U,1),"HST"))) W $E($P(^("HST"),U,1),1,10)
- W ?29,TRANS,?31,TRANS1
- ;display source of procurement 2529-3 under vendor header
- I $D(RMPRLPRO) W ?33,RMPRLPRO
- K RMPRLPRO
- I VEN'="" W ?33,$E(VEN,1,10)
- W:$G(STA)'="" ?45,$P($G(^DIC(4,STA,99)),U,1) W ?50,$E(SN,1,10),?62,DEL,?72,$J($S(CST'="":CST,$P(Y,U,17):$P(Y,U,17),1:""),0,2)
- W:REM]"" !,?5,"REMARKS: ",REM I $Y+6>IOSL D HDR^RMPRPRT,HDRH
- S (DATE,TYPE,QTY,VEN,TRANS,TRANS1,STA,SN,DEL,CST,FRM,REM)=""
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPRT1 5303 printed Mar 13, 2025@21:42:19 Page 2
- RMPRPRT1 ;PHX/HNB-CONTINUATION OF PRINT 2319 ;10/19/1993
- +1 ;;3.0;PROSTHETICS;**10,99,137,141**;Feb 09, 1996;Build 5
- +2 ;CALLED BY END^RMPRPRT
- +3 ;VARIABLES REQUIRED: R5 - A STRING ARRAY HOLDING PATIENT'S PROSTHETIC
- +4 ; DISABILITY CODE INFORMATION
- +5 NEW RMPRMERG
- SET RMPRMERG=0
- +6 IF $DATA(^XDRM("B",RMPRDFN_";DPT("))
- Begin DoDot:1
- +7 SET RMPRMERG=$ORDER(^XDRM("B",RMPRDFN_";DPT(",RMPRMERG))
- if RMPRMERG=""
- QUIT
- +8 SET RMPRMERG=+^XDRM(RMPRMERG,0)
- End DoDot:1
- +9 IF $Y>(IOSL-6)
- WRITE @IOF
- DO HDR^RMPRPRT
- +10 WRITE !!,"PSC Issue Card: "
- SET J=0
- WRITE !
- +11 FOR I=1:1
- Begin DoDot:1
- +12 IF $Y>(IOSL-6)
- WRITE @IOF
- DO HDR^RMPRPRT
- +13 SET J=$ORDER(R5(5,J))
- if J=""!(J?.A)
- QUIT
- if $GET(J)<1
- QUIT
- +14 ;S L=$P(R5(5,J,0),U,1)
- SET L=$PIECE(R5(5,J,0),U,1)
- +15 WRITE $EXTRACT(L,4,5)_"-"_$EXTRACT(L,6,7)_"-"_$EXTRACT(L,2,3),?17,"Appl: ",$SELECT($DATA(^RMPR(661,+$PIECE(R5(5,J,0),U,4),0)):$EXTRACT($PIECE(^PRC(441,+$PIECE(^(0),U),0),U,2),1,37),1:"UNKNOWN"),?66,"SN: ",$PIECE(R5(5,J,0),U,3),!
- End DoDot:1
- if J'>0
- QUIT
- +16 IF I=1
- WRITE "NONE LISTED",!
- +17 WRITE !,"Clothing Allowance: ",!
- +18 IF $DATA(R5(6))
- IF $ORDER(R5(6,0))>0
- Begin DoDot:1
- +19 FOR RI=0:0
- SET RI=$ORDER(^RMPR(665,RMPRDFN,6,"B",RI))
- if RI'>0
- QUIT
- Begin DoDot:2
- +20 SET RA=$ORDER(^RMPR(665,RMPRDFN,6,"B",RI,0))
- +21 SET RR5=R5(6,RA,0)
- SET RR5=RR5
- +22 ;D I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT
- +23 WRITE ?22,"DATE: ",$EXTRACT(RR5,4,5)_"-"_$EXTRACT(RR5,6,7)_"-"_$EXTRACT(RR5,2,3)
- +24 WRITE " ",$SELECT($PIECE(RR5,U,2)["E":"ELIGIBLE",$PIECE(RR5,U,2)["N":"NOT-ELIGIBLE",1:"")
- +25 WRITE " ",$SELECT($PIECE(RR5,U,3)["S":"STATIC",$PIECE(RR5,U,3)["N":"NON-STATIC",1:"")
- +26 IF $PIECE(RR5,U,5)
- SET Y=$PIECE(RR5,U,5)
- DO DD^%DT
- WRITE !,?22,"Date of Exam: ",Y
- if $PIECE(RR5,U,6)
- WRITE " Examiner: ",$EXTRACT($PIECE(^VA(200,$PIECE(RR5,U,6),0),U,1),1,30)
- +27 WRITE !,?22,"Desc: "
- +28 WRITE $SELECT($DATA(R5(6,RA,1)):$PIECE(R5(6,RA,1),U),1:""),!
- +29 IF $Y>(IOSL-6)
- WRITE @IOF
- DO HDR^RMPRPRT
- End DoDot:2
- End DoDot:1
- +30 IF '$DATA(R5(6))
- IF $PIECE(R5(0),U,6)=""
- WRITE "NONE LISTED",!
- +31 SET RO=0
- +32 FOR
- SET RO=$ORDER(^RMPR(667,"C",RMPRDFN,RO))
- if RO'>0
- QUIT
- Begin DoDot:1
- +33 if $PIECE(^RMPR(667,RO,2),U,1)=0
- QUIT
- +34 if '$DATA(RMPRFLG)
- WRITE !,"Automobile(s):",?15,"Make",?27,"Model",?39,"Vehical ID #",?62,"Date Processed"
- +35 if '$PIECE(^RMPR(667,RO,0),U,6)'=""
- WRITE !?15,$EXTRACT($PIECE(^RMPR(667.2,$PIECE(^RMPR(667,RO,0),U,6),0),U,1),1,11),?27,$EXTRACT($PIECE(^RMPR(667,RO,0),U,7),1,10),?39,$PIECE(^RMPR(667,RO,0),U,1)
- SET Y=$PIECE(^RMPR(667,RO,0),U,8)
- DO DD^%DT
- WRITE ?64,Y
- SET RMPRFLG=1
- End DoDot:1
- IF $Y>(IOSL-6)
- WRITE @IOF
- DO HDR^RMPRPRT
- +36 IF '$DATA(RMPRFLG)
- WRITE !,"Automobile(s): NONE LISTED"
- +37 WRITE !,"Items Returned: "
- +38 IF $DATA(^RMPR(665,RMPRDFN,7,0))
- DO OLD^RMPRPAT1
- +39 IF $DATA(^RMPR(660.1,"C",RMPRDFN))
- SET RO=0
- FOR
- SET RO=$ORDER(^RMPR(660.1,"C",RMPRDFN,RO))
- if RO'>0
- QUIT
- DO WRIL^RMPRPAT1
- +40 IF '$DATA(^RMPR(660.1,"C",RMPRDFN))
- WRITE "NONE LISTED"
- +41 ;W !!,"Items on loan: " I $D(^RMPR(660.1,"C",RMPRDFN)) S RO=0 F S RO=$O(^RMPR(660.1,"C",RMPRDFN,RO)) Q:RO="" D WRIL^RMPRPAT1
- +42 WRITE !!,"Other Data: "
- SET J=0
- FOR I=1:1
- SET J=$ORDER(R5(4,J))
- if J=""!(J?.A)
- QUIT
- WRITE !?5,R5(4,J,0)
- IF $Y>(IOSL-6)
- WRITE @IOF
- DO HDR^RMPRPRT
- +43 IF I=1
- WRITE "NONE LISTED"
- +44 IF $Y>(IOSL-6)
- WRITE @IOF
- DO HDR^RMPRPRT
- +45 WRITE !,"RECORD OF APPLIANCES/REPAIRS: "
- DO HDRH
- SET RC=0
- SET (RA,AN)=""
- +46 SET RA=""
- +47 FOR
- SET RA=$ORDER(^RMPR(660,"AC",RMPRDFN,RA))
- if RA'>0
- QUIT
- SET AN=""
- FOR
- SET AN=$ORDER(^RMPR(660,"AC",RMPRDFN,RA,AN))
- if AN'>0
- QUIT
- SET RC=RC+1
- SET Y=^RMPR(660,AN,0)
- DO PRT
- IF $Y>(IOSL-6)
- WRITE @IOF
- DO HDR^RMPRPRT
- +48 SET RA=""
- +49 IF RMPRMERG
- Begin DoDot:1
- +50 FOR
- SET RA=$ORDER(^RMPR(660,"AC",RMPRMERG,RA))
- if RA'>0
- QUIT
- SET AN=""
- FOR
- SET AN=$ORDER(^RMPR(660,"AC",RMPRMERG,RA,AN))
- if AN'>0
- QUIT
- SET RC=RC+1
- SET Y=^RMPR(660,AN,0)
- DO PRT
- IF $Y>(IOSL-6)
- WRITE @IOF
- DO HDR^RMPRPRT
- End DoDot:1
- +51 IF RC=0
- WRITE !,"No Appliances or Repairs exist for this veteran!",!!
- +52 IF '$TEST
- WRITE !!,"End of Appliance/Repair records for this veteran!",!!," *Historical Item"
- EXIT KILL I,IT,J,L,RC,K,RA,AN,DATE,TYPE,QTY,VEN,TRANS,TRANS1,STA,SN,DEL,CST,FRM,REM,R0,RMPRE,RMPRFLG,RO,Y
- GOTO EXIT^RMPRPRT
- HDRH WRITE !!?4,"DATE",?13,"QTY",?17," HCPCS DESC",?29,"N R ",?33,"VENDOR",?45,"STA",?50,"SERIAL NBR",?62,"DELIVERED",?72,"COST",!
- +1 FOR L=1:1:79
- WRITE "-"
- +2 QUIT
- PRT SET DATE=$PIECE(Y,U,3)
- SET TYPE=$PIECE(Y,U,6)
- SET QTY=$PIECE(Y,U,7)
- SET VEN=$PIECE(Y,U,9)
- SET TRANS=$PIECE(Y,U,4)
- SET STA=$PIECE(Y,U,10)
- SET SN=$PIECE(Y,U,11)
- SET DEL=$PIECE(Y,U,12)
- SET AMIS=$PIECE(Y,U,15)
- +1 ;include 2529-3 data
- +2 SET CST=$SELECT($PIECE(Y,U,16)'="":$PIECE(Y,U,16),$DATA(^RMPR(660,AN,"LB")):$PIECE(^RMPR(660,AN,"LB"),U,9),1:"")
- +3 ;vendor 2529-3
- +4 IF $DATA(^RMPR(660,AN,"LB"))
- SET RMPRLPRO=$PIECE(^("LB"),U,3)
- Begin DoDot:1
- +5 IF RMPRLPRO="O"
- SET RMPRLPRO="ORTHOTIC"
- QUIT
- +6 IF RMPRLPRO="R"
- SET RMPRLPRO="RESTROATION"
- QUIT
- +7 IF RMPRLPRO="S"
- SET RMPRLPRO="SHOE"
- QUIT
- +8 IF RMPRLPRO="W"
- SET RMPRLPRO="WHEELCHAIR"
- QUIT
- +9 IF RMPRLPRO="N"
- SET RMPRLPRO="FOOT CENTER"
- QUIT
- +10 IF RMPRLPRO="D"
- SET RMPRLPRO="DDC"
- QUIT
- End DoDot:1
- +11 SET FRM=$PIECE(Y,U,13)
- SET REM=$PIECE(Y,U,18)
- SET DATE=$EXTRACT(DATE,4,5)_"/"_$EXTRACT(DATE,6,7)_"/"_$EXTRACT(DATE,2,3)
- +12 ;S TYPE=$S(TYPE="":"",$D(^RMPR(661,TYPE,0)):$P(^(0),U,1),1:"")
- +13 SET TYPE=$PIECE($GET(^RMPR(660,AN,1)),U,4)
- +14 SET VEN=$SELECT(VEN="":"",$DATA(^PRC(440,VEN,0)):$PIECE(^(0),U,1),1:"")
- +15 SET TRANS=$SELECT(TRANS]"":TRANS,1:"")
- SET TRANS1=""
- if TRANS="X"
- SET TRANS1=TRANS
- SET TRANS=""
- +16 SET DEL=$EXTRACT(DEL,4,5)_"/"_$EXTRACT(DEL,6,7)_"/"_$EXTRACT(DEL,2,3)
- if DEL="//"
- SET DEL=""
- +17 WRITE !,RC,". ",DATE,?13,QTY,?17
- +18 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:"")
- +19 ;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:"")
- +20 ;I TYPE=""&($D(^RMPR(660,$P(IT(RK),U,1),"HST"))) W $E($P(^("HST"),U,1),1,10)
- +21 WRITE ?29,TRANS,?31,TRANS1
- +22 ;display source of procurement 2529-3 under vendor header
- +23 IF $DATA(RMPRLPRO)
- WRITE ?33,RMPRLPRO
- +24 KILL RMPRLPRO
- +25 IF VEN'=""
- WRITE ?33,$EXTRACT(VEN,1,10)
- +26 if $GET(STA)'=""
- WRITE ?45,$PIECE($GET(^DIC(4,STA,99)),U,1)
- WRITE ?50,$EXTRACT(SN,1,10),?62,DEL,?72,$JUSTIFY($SELECT(CST'="":CST,$PIECE(Y,U,17):$PIECE(Y,U,17),1:""),0,2)
- +27 if REM]""
- WRITE !,?5,"REMARKS: ",REM
- IF $Y+6>IOSL
- DO HDR^RMPRPRT
- DO HDRH
- +28 SET (DATE,TYPE,QTY,VEN,TRANS,TRANS1,STA,SN,DEL,CST,FRM,REM)=""
- +29 QUIT
