- RMPRDP ;PHX/HNC-RECORD PICKUP AND DELIVERY CHARGES ;8/29/1994
- ;;3.0;PROSTHETICS;**24,34,41,62**;Feb 09, 1996
- ;RVD patch #62 - PCE interface
- EN ;ENTRY POINT FOR PICKUP AND DELIVERY. CALLED FROM RMPROP.
- K ^TMP($J)
- D DIV4^RMPRSIT G:$D(X) EXIT
- S PRCS("A")="Select OBLIGATION NUMBER: " D EN1^PRCS58 G:Y=-1 EXIT S RMPROB=$P(Y,U,2) K PRCS("A") D BAL^RMPRPSC
- A S RMPRF=99 W !,"This will Post Pickup and Delivery Charges to the 1358 and 10-2319 ",!
- S %=1 R "Do you wish to Continue" D YN^DICN S RMPRACT=$S(%=-1:"EXIT",%=1:"ADD",%=2:"EXIT",%=0:"HLP",1:"EXIT") K:(%=2)!(%=-1) RMPROB G @RMPRACT
- ADD D GETPAT^RMPRUTIL G:'$D(RMPRDFN) EXIT S RMPRFLAG=1 S RMPRBAC1=1 D ^RMPRPAT I $D(RMPRKILL) W !,"Deleted..." G EXIT
- S X=DT,DIC="^RMPR(664,",DIC(0)="AEQML",DLAYGO=664,DIC("DR")="1////^S X=RMPRDFN" K DINUM,DD,DO D FILE^DICN K DLAYGO Q:Y<0 S (RMPRK,RMPRA)=+Y S $P(^RMPR(664,+Y,0),U,14)=RMPR("STA")
- ;added for PSAS HCPCS prompt
- HC K DIR,Y,DA S DIR(0)="660,4.5",DIR("A")="Enter PSAS HCPCS" D ^DIR G:$D(DUOUT)!($D(DTOUT)) KILL I X="" W $C(7)," ??" G HC
- S (X,RMHCPC)=+Y,RMTYPE="X",RDA=RMHCPC_"^"_RMTYPE_"^C^"_664
- CPT D CPT^RMPRCPTU(RDA)
- S DIE=DIC,DA=RMPRA,DR="4;10////^S X=DUZ;11R~UNIT COST;14REMARKS" D ^DIE
- I $D(DTOUT)!($D(Y)'=0) W !,$C(7),$C(7),"Please Try Later!" G KILL
- PD K DIR,Y,DA S DIR(0)="660,6.5",DIR("A")="Select PICKUP OR DELIVERY" D ^DIR G:$D(DUOUT)!($D(DTOUT)) KILL I X="" W $C(7)," ??" G PD
- S RMPRPD=Y
- PC K DIR,Y S DIR(0)="660,62" D ^DIR G:$D(DUOUT)!($D(DTOUT)) KILL S RMPREL=Y
- SC K DIR I RMPREL=4 S DIR(0)="660,63" D ^DIR G:$D(DTOUT)!($D(DUOUT)) KILL S RMPRSE=Y K DIR
- POST S %=2 R !,"Are you ready to POST to IFCAP and 10-2319 now" D YN^DICN G:$D(DTOUT) KILL G:%=1 FILE G:%=-1 DEL
- W !!,"This will post an Est. $",$J($P(^RMPR(664,RMPRA,0),U,10),0,2)," on the 1358 Transaction and,",!,"$",$J($P(^(0),U,10),0,2)," on the 10-2319 Record.",!,"Type '^' to delete and exit.",! G POST
- FILE W !,"Posting Now..."
- S X=RMPROB_U_DT_U_$P(^RMPR(664,RMPRA,0),U,10)_U_U_$E($P(RMPRNAM,",",1),1,6)_","_$E(RMPRSSN,6,9)_U_$P(^(0),U,13)
- S PRCS("TYPE")="FB" K DO,DD,D0 D EN2^PRCS58 G:+Y'=1 ERROR S RMPRTN=$P(Y,U,2),RMPRTRN=$P(^PRC(424,RMPRTN,0),U,1)
- W !?5,"1358 Transaction has been assigned Number: ",RMPRTRN
- ;I $Y>18 K DIR S DIR(0)="FAO^0:0",DIR("A")="Press 'RETURN' to continue." D ^DIR K DIR
- S RMPRV=$P(^RMPR(664,RMPRA,0),U,4),$P(^RMPR(664,RMPRA,0),U,7)=RMPRTRN,$P(^RMPR(664,RMPRA,0),U,6)=PRCSCPAN S DA=RMPRA,DIK="^RMPR(664," D IX1^DIK
- S X=DT,DIC="^RMPR(660,",DIC(0)="LQ",X=DT,DLAYGO=660 K DINUM,DO,DD D FILE^DICN S RMPR660=+Y K DLAYGO
- S ^RMPR(660,RMPR660,0)=DT_U_RMPRDFN_U_DT_U_"X"_"^^^^^"_RMPRV_U_RMPR("STA")_"^^^9^C^^"_$P(^RMPR(664,RMPRA,0),U,10)_U_$P(^RMPR(664,RMPRA,0),U,10)_U_$P(^(0),U,13)_"^^^^^^^^"_RMPRPD_U_DUZ
- S ^RMPR(660,RMPR660,1)=RMPRTRN_"^^^"_RMHCPC_"^^"_RMCPT,^("AM")=U_U_RMPREL_U_$S($D(RMPRSE):RMPRSE,1:"")
- L +^RMPR(669.9,RMPRSITE,0):999 I $T=0 S RMPRG=DT_99 G DIK60
- S RMPRG=$P(^RMPR(669.9,RMPRSITE,0),U,7),RMPRG=RMPRG-1
- S $P(^RMPR(669.9,RMPRSITE,0),U,7)=RMPRG L -^RMPR(669.9,RMPRSITE,0)
- S $P(^RMPR(660,RMPR660,"AMS"),U,1)=RMPRG
- DIK60 S DIK="^RMPR(660,",DA=RMPR660 D IX1^DIK
- S $P(^RMPR(664,RMPRA,0),U,3)=RMPROB,$P(^(0),U,12)=RMPR660,$P(^RMPR(664,RMPRA,2),U,4)="OTHER" S DA=RMPRA,DIK="^RMPR(664," D IX1^DIK
- ;
- W !?5,"Updated 10-2319 Record"
- ;
- ;set temp global for suspense link, added in patch #62
- S ^TMP($J,"RMPRPCE",660,RMPR660)=RMPRG_"^"_$G(RMPRDFN)
- D LINK^RMPRS
- G EXIT
- DEL S %=2 R !,"Do you want to Delete this Transaction" D YN^DICN G:%=1!(%<0) KILL I %=0 W !,"Enter `YES` to delete the transaction, `NO` to continue."
- G POST
- HLP W !,"This will create a 1358 Daily Transaction and post to Veteran's 10-2319 Record that AMIS will be counted from.",! G A
- ERROR W !,$C(7),$C(7),?5,"*** PLEASE CONTACT YOUR FISCAL SERVICE ***",!,?5,Y
- KILL S DA=RMPRK,DIK="^RMPR(664," D ^DIK K DIR W !,$C(7),?20,"Deleted..."
- S DIR(0)="E" D ^DIR
- EXIT K RMPRKILL,RMPRF,DIR,PRCSIP,RMPRDOB,RMPRFLAG,PRCSCPAN,PRCS("TYPE"),RMPRSE,RMPRV,DA,%,DIE,DIRUT,DTOUT,RMPRACT,RMPREL,RMPRK,RMPRTN,RMPRTRN,RMPRA,RMPRDFN,RMPRNAM,RMPRSSN,RMPRPD,RMPRSC,RMPRPC,RMPR660,DIK,DIC,DR,Y
- I $D(RMPROB) W @IOF D PRCS^RMPRPSC G:X'["^" A
- K ^TMP($J)
- K RMPROB,PRC,PRCS,RBL,RDA,RVA,RX,RMCPT,RMHCPC,RMPRBAC1,RMPRBACK,RMPRSSNE,PRCRI Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRDP 4265 printed Feb 19, 2025@00:00:39 Page 2
- RMPRDP ;PHX/HNC-RECORD PICKUP AND DELIVERY CHARGES ;8/29/1994
- +1 ;;3.0;PROSTHETICS;**24,34,41,62**;Feb 09, 1996
- +2 ;RVD patch #62 - PCE interface
- EN ;ENTRY POINT FOR PICKUP AND DELIVERY. CALLED FROM RMPROP.
- +1 KILL ^TMP($JOB)
- +2 DO DIV4^RMPRSIT
- if $DATA(X)
- GOTO EXIT
- +3 SET PRCS("A")="Select OBLIGATION NUMBER: "
- DO EN1^PRCS58
- if Y=-1
- GOTO EXIT
- SET RMPROB=$PIECE(Y,U,2)
- KILL PRCS("A")
- DO BAL^RMPRPSC
- A SET RMPRF=99
- WRITE !,"This will Post Pickup and Delivery Charges to the 1358 and 10-2319 ",!
- +1 SET %=1
- READ "Do you wish to Continue"
- DO YN^DICN
- SET RMPRACT=$SELECT(%=-1:"EXIT",%=1:"ADD",%=2:"EXIT",%=0:"HLP",1:"EXIT")
- if (%=2)!(%=-1)
- KILL RMPROB
- GOTO @RMPRACT
- ADD DO GETPAT^RMPRUTIL
- if '$DATA(RMPRDFN)
- GOTO EXIT
- SET RMPRFLAG=1
- SET RMPRBAC1=1
- DO ^RMPRPAT
- IF $DATA(RMPRKILL)
- WRITE !,"Deleted..."
- GOTO EXIT
- +1 SET X=DT
- SET DIC="^RMPR(664,"
- SET DIC(0)="AEQML"
- SET DLAYGO=664
- SET DIC("DR")="1////^S X=RMPRDFN"
- KILL DINUM,DD,DO
- DO FILE^DICN
- KILL DLAYGO
- if Y<0
- QUIT
- SET (RMPRK,RMPRA)=+Y
- SET $PIECE(^RMPR(664,+Y,0),U,14)=RMPR("STA")
- +2 ;added for PSAS HCPCS prompt
- HC KILL DIR,Y,DA
- SET DIR(0)="660,4.5"
- SET DIR("A")="Enter PSAS HCPCS"
- DO ^DIR
- if $DATA(DUOUT)!($DATA(DTOUT))
- GOTO KILL
- IF X=""
- WRITE $CHAR(7)," ??"
- GOTO HC
- +1 SET (X,RMHCPC)=+Y
- SET RMTYPE="X"
- SET RDA=RMHCPC_"^"_RMTYPE_"^C^"_664
- CPT DO CPT^RMPRCPTU(RDA)
- +1 SET DIE=DIC
- SET DA=RMPRA
- SET DR="4;10////^S X=DUZ;11R~UNIT COST;14REMARKS"
- DO ^DIE
- +2 IF $DATA(DTOUT)!($DATA(Y)'=0)
- WRITE !,$CHAR(7),$CHAR(7),"Please Try Later!"
- GOTO KILL
- PD KILL DIR,Y,DA
- SET DIR(0)="660,6.5"
- SET DIR("A")="Select PICKUP OR DELIVERY"
- DO ^DIR
- if $DATA(DUOUT)!($DATA(DTOUT))
- GOTO KILL
- IF X=""
- WRITE $CHAR(7)," ??"
- GOTO PD
- +1 SET RMPRPD=Y
- PC KILL DIR,Y
- SET DIR(0)="660,62"
- DO ^DIR
- if $DATA(DUOUT)!($DATA(DTOUT))
- GOTO KILL
- SET RMPREL=Y
- SC KILL DIR
- IF RMPREL=4
- SET DIR(0)="660,63"
- DO ^DIR
- if $DATA(DTOUT)!($DATA(DUOUT))
- GOTO KILL
- SET RMPRSE=Y
- KILL DIR
- POST SET %=2
- READ !,"Are you ready to POST to IFCAP and 10-2319 now"
- DO YN^DICN
- if $DATA(DTOUT)
- GOTO KILL
- if %=1
- GOTO FILE
- if %=-1
- GOTO DEL
- +1 WRITE !!,"This will post an Est. $",$JUSTIFY($PIECE(^RMPR(664,RMPRA,0),U,10),0,2)," on the 1358 Transaction and,",!,"$",$JUSTIFY($PIECE(^(0),U,10),0,2)," on the 10-2319 Record.",!,"Type '^' to delete and exit.",!
- GOTO POST
- FILE WRITE !,"Posting Now..."
- +1 SET X=RMPROB_U_DT_U_$PIECE(^RMPR(664,RMPRA,0),U,10)_U_U_$EXTRACT($PIECE(RMPRNAM,",",1),1,6)_","_$EXTRACT(RMPRSSN,6,9)_U_$PIECE(^(0),U,13)
- +2 SET PRCS("TYPE")="FB"
- KILL DO,DD,D0
- DO EN2^PRCS58
- if +Y'=1
- GOTO ERROR
- SET RMPRTN=$PIECE(Y,U,2)
- SET RMPRTRN=$PIECE(^PRC(424,RMPRTN,0),U,1)
- +3 WRITE !?5,"1358 Transaction has been assigned Number: ",RMPRTRN
- +4 ;I $Y>18 K DIR S DIR(0)="FAO^0:0",DIR("A")="Press 'RETURN' to continue." D ^DIR K DIR
- +5 SET RMPRV=$PIECE(^RMPR(664,RMPRA,0),U,4)
- SET $PIECE(^RMPR(664,RMPRA,0),U,7)=RMPRTRN
- SET $PIECE(^RMPR(664,RMPRA,0),U,6)=PRCSCPAN
- SET DA=RMPRA
- SET DIK="^RMPR(664,"
- DO IX1^DIK
- +6 SET X=DT
- SET DIC="^RMPR(660,"
- SET DIC(0)="LQ"
- SET X=DT
- SET DLAYGO=660
- KILL DINUM,DO,DD
- DO FILE^DICN
- SET RMPR660=+Y
- KILL DLAYGO
- +7 SET ^RMPR(660,RMPR660,0)=DT_U_RMPRDFN_U_DT_U_"X"_"^^^^^"_RMPRV_U_RMPR("STA")_"^^^9^C^^"_$PIECE(^RMPR(664,RMPRA,0),U,10)_U_$PIECE(^RMPR(664,RMPRA,0),U,10)_U_$PIECE(^(0),U,13)_"^^^^^^^^"_RMPRPD_U_DUZ
- +8 SET ^RMPR(660,RMPR660,1)=RMPRTRN_"^^^"_RMHCPC_"^^"_RMCPT
- SET ^("AM")=U_U_RMPREL_U_$SELECT($DATA(RMPRSE):RMPRSE,1:"")
- +9 LOCK +^RMPR(669.9,RMPRSITE,0):999
- IF $TEST=0
- SET RMPRG=DT_99
- GOTO DIK60
- +10 SET RMPRG=$PIECE(^RMPR(669.9,RMPRSITE,0),U,7)
- SET RMPRG=RMPRG-1
- +11 SET $PIECE(^RMPR(669.9,RMPRSITE,0),U,7)=RMPRG
- LOCK -^RMPR(669.9,RMPRSITE,0)
- +12 SET $PIECE(^RMPR(660,RMPR660,"AMS"),U,1)=RMPRG
- DIK60 SET DIK="^RMPR(660,"
- SET DA=RMPR660
- DO IX1^DIK
- +1 SET $PIECE(^RMPR(664,RMPRA,0),U,3)=RMPROB
- SET $PIECE(^(0),U,12)=RMPR660
- SET $PIECE(^RMPR(664,RMPRA,2),U,4)="OTHER"
- SET DA=RMPRA
- SET DIK="^RMPR(664,"
- DO IX1^DIK
- +2 ;
- +3 WRITE !?5,"Updated 10-2319 Record"
- +4 ;
- +5 ;set temp global for suspense link, added in patch #62
- +6 SET ^TMP($JOB,"RMPRPCE",660,RMPR660)=RMPRG_"^"_$GET(RMPRDFN)
- +7 DO LINK^RMPRS
- +8 GOTO EXIT
- DEL SET %=2
- READ !,"Do you want to Delete this Transaction"
- DO YN^DICN
- if %=1!(%<0)
- GOTO KILL
- IF %=0
- WRITE !,"Enter `YES` to delete the transaction, `NO` to continue."
- +1 GOTO POST
- HLP WRITE !,"This will create a 1358 Daily Transaction and post to Veteran's 10-2319 Record that AMIS will be counted from.",!
- GOTO A
- ERROR WRITE !,$CHAR(7),$CHAR(7),?5,"*** PLEASE CONTACT YOUR FISCAL SERVICE ***",!,?5,Y
- KILL SET DA=RMPRK
- SET DIK="^RMPR(664,"
- DO ^DIK
- KILL DIR
- WRITE !,$CHAR(7),?20,"Deleted..."
- +1 SET DIR(0)="E"
- DO ^DIR
- EXIT KILL RMPRKILL,RMPRF,DIR,PRCSIP,RMPRDOB,RMPRFLAG,PRCSCPAN,PRCS("TYPE"),RMPRSE,RMPRV,DA,%,DIE,DIRUT,DTOUT,RMPRACT,RMPREL,RMPRK,RMPRTN,RMPRTRN,RMPRA,RMPRDFN,RMPRNAM,RMPRSSN,RMPRPD,RMPRSC,RMPRPC,RMPR660,DIK,DIC,DR,Y
- +1 IF $DATA(RMPROB)
- WRITE @IOF
- DO PRCS^RMPRPSC
- if X'["^"
- GOTO A
- +2 KILL ^TMP($JOB)
- +3 KILL RMPROB,PRC,PRCS,RBL,RDA,RVA,RX,RMCPT,RMHCPC,RMPRBAC1,RMPRBACK,RMPRSSNE,PRCRI
- QUIT