- RMPOBIL7 ;HINES CIO/RVD - HOME OXYGEN BILLING TRANSACTIONS ;9/16/02 11:11
- ;;3.0;PROSTHETICS;**70,99**;Feb 09, 1996
- ;RVD 7/8/02 patch #70 - this is a copy of RMPOBIL5 routine.
- ; For Read Only 2319.
- ;
- ;DBIA # 800 - for this routine, the agreement covers the field #.01 NAME
- ; file #440.
- ;DBIA # 801 - for this routine, the agreement covers the field
- ; #.05 Short Description, file #441.
- ;DBIA # 10090 - Fileman read of file #4, field #99.
- ;
- N DA,DR,DIQ,DIC
- K ^UTILITY("DIQ1",$J)
- S (RC,RA,AN,ANS,RK,RZ)=0 D HDR
- F S RA=$O(^RMPR(660,"AC",RMPRDFN,RA)) Q:RA="" D
- . S AN=""
- . F S AN=$O(^RMPR(660,"AC",RMPRDFN,RA,AN)) Q:AN="" D
- . . I $D(^RMPO(665.72,"AC",AN))>0 S RC=RC+1,IT(RC)=AN
- G:'$D(IT) END
- DIS ;DISPLAY APPLIANCES OR REPAIRS
- I $G(RK)="" S (RC,RK)=""
- I RK+1'>RC S RK=RK+1,AN=+IT(RK) D G:$$XIT EXIT G DIS
- . S Y=^RMPR(660,AN,0) D PRT,OVER:((IOSL-4)<$Y)
- END I RC=0 W !,"No home oxygen items for this veteran!",!! H 3 G EXIT
- E D G EXIT
- .I RC>0 D I $G(RK)+1'>$G(RC) D DIS
- . . W !!,"End of Home Oxygen records for this veteran!" D OVER
- .I $G(RC)="" Q
- EXIT Q:'$D(RMPRDFN)
- W ! K I,J,L,R0,IT,RA
- I $D(DUOUT)!($D(DTOUT)) G ASK1^RMPOPAT
- S FL=4 G ASK2^RMPOPAT
- K RMPRCNUM,TRANS,TRANS1,TYPE,VEN,RMPRSTN,DIQ,^UTILITY("DIQ1",$J)
- K AMIS,AN,CST,DATE,DEL,DUOUT,DTOUT,FL,FRM,PAGE,QTY,RC,REM,RZ,RK,SN,STA
- Q
- XIT() Q '$D(ANS)!(ANS=U)!($D(DUOUT))!($D(DTOUT))
- PRT MERGE RMY=Y
- 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:"")
- ;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:"")
- S TYPE=$P($G(^RMPR(660,AN,1)),U,4)
- 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,1),1,10),$P(Y,U,26)="D":"DELIVERY",$P(Y,U,26)="P":"PICKUP",$P(Y,U,17):"SHIPPING",1:"")
- ;W:$D(^RMPR(660,$P(IT(RK),U,1),"HST")) $E($P(^("HST"),U,1),1,10)
- 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
- K RMPRLPRO
- I VEN'="" W ?33,$E(VEN,1,10)
- W:$D(^RMPR(660,$P(IT(RK),U,1),"HST")) $E($P(^("HST"),U,3),1,10)
- I STA'="" D
- .S DIC="^DIC(4,",DIQ(0)="E",DR=99,DIQ="RMPRSTN",DA=STA D EN^DIQ1
- .W:$D(RMPRSTN(4,STA,99,"E")) ?45,RMPRSTN(4,STA,99,"E")
- W ?50,$E(SN,1,9),?60,DEL
- W ?71,$J($FN($S(CST'="":CST,$P(RMY,U,17):$P(RMY,U,17),1:""),"T",2),9)
- W:REM]"" !,?3,REM
- I $P(IT(RK),U,2)="" S IT(RK)=IT(RK)_"^"_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="^" G ASK1^RMPOPAT Q
- I ANS="^" G ASK1^RMPOPAT Q
- I ANS="",RK+1'>RC 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 ^RMPOPAT3 I RMOXY=0 K RK Q
- 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,"Item",?28,"Type",?34,"Vendor",?45,"Sta",?50,"Serial",?58,"Delivery Date",?72,"Tot Cost"
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPOBIL7 4082 printed Feb 18, 2025@23:57:18 Page 2
- RMPOBIL7 ;HINES CIO/RVD - HOME OXYGEN BILLING TRANSACTIONS ;9/16/02 11:11
- +1 ;;3.0;PROSTHETICS;**70,99**;Feb 09, 1996
- +2 ;RVD 7/8/02 patch #70 - this is a copy of RMPOBIL5 routine.
- +3 ; For Read Only 2319.
- +4 ;
- +5 ;DBIA # 800 - for this routine, the agreement covers the field #.01 NAME
- +6 ; file #440.
- +7 ;DBIA # 801 - for this routine, the agreement covers the field
- +8 ; #.05 Short Description, file #441.
- +9 ;DBIA # 10090 - Fileman read of file #4, field #99.
- +10 ;
- +11 NEW DA,DR,DIQ,DIC
- +12 KILL ^UTILITY("DIQ1",$JOB)
- +13 SET (RC,RA,AN,ANS,RK,RZ)=0
- DO HDR
- +14 FOR
- SET RA=$ORDER(^RMPR(660,"AC",RMPRDFN,RA))
- if RA=""
- QUIT
- Begin DoDot:1
- +15 SET AN=""
- +16 FOR
- SET AN=$ORDER(^RMPR(660,"AC",RMPRDFN,RA,AN))
- if AN=""
- QUIT
- Begin DoDot:2
- +17 IF $DATA(^RMPO(665.72,"AC",AN))>0
- SET RC=RC+1
- SET IT(RC)=AN
- End DoDot:2
- End DoDot:1
- +18 if '$DATA(IT)
- GOTO END
- DIS ;DISPLAY APPLIANCES OR REPAIRS
- +1 IF $GET(RK)=""
- SET (RC,RK)=""
- +2 IF RK+1'>RC
- SET RK=RK+1
- SET AN=+IT(RK)
- Begin DoDot:1
- +3 SET Y=^RMPR(660,AN,0)
- DO PRT
- if ((IOSL-4)<$Y)
- DO OVER
- End DoDot:1
- if $$XIT
- GOTO EXIT
- GOTO DIS
- END IF RC=0
- WRITE !,"No home oxygen items for this veteran!",!!
- HANG 3
- GOTO EXIT
- +1 IF '$TEST
- Begin DoDot:1
- +2 IF RC>0
- Begin DoDot:2
- +3 WRITE !!,"End of Home Oxygen records for this veteran!"
- DO OVER
- End DoDot:2
- IF $GET(RK)+1'>$GET(RC)
- DO DIS
- +4 IF $GET(RC)=""
- QUIT
- End DoDot:1
- GOTO EXIT
- EXIT if '$DATA(RMPRDFN)
- QUIT
- +1 WRITE !
- KILL I,J,L,R0,IT,RA
- +2 IF $DATA(DUOUT)!($DATA(DTOUT))
- GOTO ASK1^RMPOPAT
- +3 SET FL=4
- GOTO ASK2^RMPOPAT
- +4 KILL RMPRCNUM,TRANS,TRANS1,TYPE,VEN,RMPRSTN,DIQ,^UTILITY("DIQ1",$JOB)
- +5 KILL AMIS,AN,CST,DATE,DEL,DUOUT,DTOUT,FL,FRM,PAGE,QTY,RC,REM,RZ,RK,SN,STA
- +6 QUIT
- XIT() QUIT '$DATA(ANS)!(ANS=U)!($DATA(DUOUT))!($DATA(DTOUT))
- PRT MERGE RMY=Y
- +1 SET DATE=$PIECE(Y,U,3)
- SET TYPE=$PIECE(Y,U,6)
- SET QTY=$PIECE(Y,U,7)
- +2 SET VEN=$PIECE(Y,U,9)
- SET TRANS=$PIECE(Y,U,4)
- SET STA=$PIECE(Y,U,10)
- SET SN=$PIECE(Y,U,11)
- +3 SET DEL=$PIECE(Y,U,12)
- +4 SET CST=$SELECT($PIECE(Y,U,16)'="":$PIECE(Y,U,16),$DATA(^RMPR(660,AN,"LB")):$PIECE(^RMPR(660,AN,"LB"),U,9),1:"")
- +5 ;form requested on
- +6 SET FRM=$PIECE(Y,U,13)
- SET REM=$PIECE(Y,U,18)
- +7 SET DATE=$EXTRACT(DATE,4,5)_"/"_$EXTRACT(DATE,6,7)_"/"_$EXTRACT(DATE,2,3)
- +8 ;S TYPE=$S(TYPE="":"",$D(^RMPR(661,TYPE,0)):$P(^(0),U,1),1:"")
- +9 SET TYPE=$PIECE($GET(^RMPR(660,AN,1)),U,4)
- +10 SET AMIS=$PIECE(Y,U,15)
- SET VEN=$SELECT(VEN="":"",$DATA(^PRC(440,VEN,0)):$PIECE(^(0),U,1),1:"")
- +11 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_"+"
- +12 SET TRANS=$SELECT(TRANS]"":TRANS,1:"")
- SET TRANS1=""
- +13 if TRANS="X"
- SET TRANS1=TRANS
- SET TRANS=""
- +14 SET DEL=$EXTRACT(DEL,4,5)_"/"_$EXTRACT(DEL,6,7)_"/"_$EXTRACT(DEL,2,3)
- if DEL="//"
- SET DEL=""
- +15 WRITE !,RK,". ",DATE,?13,QTY,?17
- +16 ;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:"")
- +17 WRITE AMIS_$SELECT(TYPE'="":$EXTRACT($PIECE($GET(^RMPR(661.1,TYPE,0)),U,1),1,10),$PIECE(Y,U,26)="D":"DELIVERY",$PIECE(Y,U,26)="P":"PICKUP",$PIECE(Y,U,17):"SHIPPING",1:"")
- +18 ;W:$D(^RMPR(660,$P(IT(RK),U,1),"HST")) $E($P(^("HST"),U,1),1,10)
- +19 IF TYPE=""&($DATA(^RMPR(660,$PIECE(IT(RK),U,1),"HST")))
- WRITE $EXTRACT($PIECE(^("HST"),U,1),1,10)
- +20 WRITE ?30,TRANS,?31,TRANS1
- +21 ;display source of procurement for 2529-3 under vendor header
- +22 IF $DATA(RMPRLPRO)
- WRITE ?33,RMPRLPRO
- +23 KILL RMPRLPRO
- +24 IF VEN'=""
- WRITE ?33,$EXTRACT(VEN,1,10)
- +25 if $DATA(^RMPR(660,$PIECE(IT(RK),U,1),"HST"))
- WRITE $EXTRACT($PIECE(^("HST"),U,3),1,10)
- +26 IF STA'=""
- Begin DoDot:1
- +27 SET DIC="^DIC(4,"
- SET DIQ(0)="E"
- SET DR=99
- SET DIQ="RMPRSTN"
- SET DA=STA
- DO EN^DIQ1
- +28 if $DATA(RMPRSTN(4,STA,99,"E"))
- WRITE ?45,RMPRSTN(4,STA,99,"E")
- End DoDot:1
- +29 WRITE ?50,$EXTRACT(SN,1,9),?60,DEL
- +30 WRITE ?71,$JUSTIFY($FNUMBER($SELECT(CST'="":CST,$PIECE(RMY,U,17):$PIECE(RMY,U,17),1:""),"T",2),9)
- +31 if REM]""
- WRITE !,?3,REM
- +32 IF $PIECE(IT(RK),U,2)=""
- SET IT(RK)=IT(RK)_"^"_RZ
- +33 QUIT
- OVER NEW ANS
- +1 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="^"
- +2 IF ANS="^^"
- SET ANS="^"
- GOTO ASK1^RMPOPAT
- QUIT
- +3 IF ANS="^"
- GOTO ASK1^RMPOPAT
- QUIT
- +4 IF ANS=""
- IF RK+1'>RC
- DO HDR
- QUIT
- +5 IF ANS=""
- QUIT
- +6 IF ANS'?1N.N!(ANS>RK)!(+ANS=0)!(+ANS'=ANS)
- WRITE $CHAR(7),!," Must be between 1 and ",RK," to be valid"
- GOTO OVER
- +7 IF ANS>0
- IF (ANS<(RK+1))
- SET AN=ANS
- SET RZ=RK
- DO ^RMPOPAT3
- IF RMOXY=0
- KILL RK
- QUIT
- +8 SET RK=$PIECE(IT(ANS),U,2)
- +9 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,"Item",?28,"Type",?34,"Vendor",?45,"Sta",?50,"Serial",?58,"Delivery Date",?72,"Tot Cost"
- +9 QUIT