RMPRPSC ;PHX/HNB-PRINT PSC LISTING ;8/29/1994
;;3.0;PROSTHETICS;;Feb 09, 1996
EN ;entry to Prosthetic Service Card from purchasing
W !!?7,"NAME",?50,"SERIAL NUMBER",!
S RMPRX=0 F I=0:0 S I=$O(^RMPR(665,RMPRDFN,5,I)) Q:I'>0 D PRT
R !!,"SELECT NUMBER: ",RMPRPC:DTIME I '$T!(RMPRPC["^") S RMPRFLG=1 Q
I '$D(^RMPR(665,RMPRDFN,5,+RMPRPC,0)) W !?5,$C(7),$C(7),"To obligate funds on this transaction, the veteran must",!?5,"have a PSC issued for that item." G EN
S RMPRPI=$P(^RMPR(665,RMPRDFN,5,+RMPRPC,0),U,4) I RMPRPI="" W !,$C(7) G EN
S RMPRSR(RMPRPI)=$P(^RMPR(665,RMPRDFN,5,+RMPRPC,0),U,3)
S RMPRPI=$P(^RMPR(661,RMPRPI,0),U,1)
;MUST PASS RMPRSR,RMPRPI TO RMPR21 TO POST SERIAL NUMBERS
K RMPRX,RMPRIN,RMPRI,RMPRPC Q
;
PRT ;print items
S RMPRX=^RMPR(665,RMPRDFN,5,I,0),RMPRI=$P(RMPRX,U,4) I RMPRI'="" S RMPRIN=$P(^RMPR(661,RMPRI,0),U,1),RMPRIN=$E($P(^PRC(441,RMPRIN,0),U,2),1,30)
I RMPRI'="" W !,I_".",?7,$S($P(RMPRX,U,2)?1A.E:$P(RMPRX,U,2),1:RMPRIN),?50,$P(RMPRX,U,3)
Q
PSC ;ENTRY POINT FOR CREATING PSC ITEMS FOR A PATIENT
S DIC="^RMPR(665,",DIC(0)="AEQMZ" D ^DIC G:+Y'>0 EXIT S RMPRDFN=+Y
DT ;ENTER EDIT PSC CARD
I '$D(^RMPR(665,RMPRDFN,5)) S ^RMPR(665,RMPRDFN,5,0)="^665.012ID^0^0"
S DIC="^RMPR(665,"_RMPRDFN_",5,",DIC(0)="AEQMZL",DLAYGO=665
S DIC("W")="W "" "",$S($P(^(0),U,2)]"""":$E($P(^(0),U,2),1,30),$D(^RMPR(661,+$P(^(0),U,4),0)):$E($P(^PRC(441,$P(^(0),U,1),0),U,2),1,30),1:"""")_"" ""_$P(^RMPR(665,RMPRDFN,5,Y,0),U,3)"
D ^DIC K DLAYGO I +Y'>0 K DIC,DIE,DA,Y G:$D(RFL) EXIT G PSC
L +^RMPR(665,RMPRDFN,5,+Y):1 I $T=0 W !,?5,$C(7),"Someone is Editing this entry!" G EXIT
S DIE=DIC,NEW=+$P(Y,U,3),DA(1)=RMPRDFN,(DA,RDA)=+Y S DR=$S(NEW:".01:1",'NEW:".01:3") D ^DIE L -^RMPR(665,RMPRDFN,5,RDA)
I '$D(^RMPR(665,RMPRDFN,5,RDA,0)) G DT
I $D(^RMPR(665,DA(1),5,DA,0))&'$P(^(0),U,4) S DIK="^RMPR(665,"_RMPRDFN_",5,",DA(1)=RMPRDFN D ^DIK W !,?5,$C(7),"Deleted..." K DIE,DIC,DA G DT
G:'NEW DT S DR="2:3" D ^DIE G DT
EXIT ;common exit point
Q:$D(RMPRFLAG) K DIC,DIE,R90,RDA,DR,NEW Q
EYE ;EDIT FOR EYE GLASSES
;
S VENDOR=$$VEN^RMPR31U($P($G(^RMPR(660.5,+$G(RMPRDA),0)),U,4))
I VENDOR="Vendor not found" S VENDOR=""
S DR="4//^S X=VENDOR" D ^DIE K VENDOR
I $D(DTOUT)!($D(Y)'=0) G KILL^RMPR21
;
AA S X=$P($G(^RMPR(669.9,RMPRSITE,3)),U,3) I X'="" S DIC("B")=$$ITM^RMPR31U(X)
K DIC,Y S DIC=661,DIC(0)="AEQMZ",DIC("A")="ITEM (for AMIS): ",DIC("S")="S Z=$P(^(0),U,3),R1=$P(^(0),U,4) I +R1>0,+Z>0 I $P(^RMPR(663,+Z,0),U,1)=11!($P(^RMPR(663,+R1,0),U,1)=""R06"")" D ^DIC I +Y'>0 G KILL^RMPR21
K DIC,Y S DIC=661,DIC(0)="MZ",X="EYEGLASSES",DIC("S")="S R90=$P(^(0),U,3),R1=$P(^(0),U,4) I +R1>0,+R90>0 I $P(^RMPR(663,+R90,0),U,1)=11!($P(^RMPR(663,+R1,0),U,1)=""R06"")" D ^DIC I +Y'>0 G KILL^RMPR21
K DIC,DIE S RMPRPI=$P(Y,U,2) S DIE="^RMPR(664,",DR="[RMPREYE]"
D ^DIE G CHK^RMPR21
PRCS ;ENTRY POINT FOR DISPLAYING 1358 BALANCE
D EN3^PRCSUT I Y=-1 Q
K PRCS W !,"Select OBLIGATION NUMBER: ",RMPROB,"// " R X:DTIME S:'$T X="^" W:X["?" !!,?5,"Please Enter '^' to Exit" Q:X["^" S X=$S(X="":RMPROB,1:X) S DIC("S")="S RX=^(0) I +RX=+PRC(""SITE""),+$P(RX,U,3)=+PRC(""CP""),+$P(RX,U,2)=21"
S DIC=442,DIC(0)="MQXZ" D ^DIC G:+Y'>0 PRCS S RMPROB=$P(Y,U,2)
BAL ;check IFCAP version
S RDA=$O(^DIC(9.4,"C","PRC",0)) I $D(^DIC(9.4,+RDA,"VERSION")) S RVA=+^("VERSION")
I +RVA<4 W !,"1358 Balance is $",$FN($P(^PRC(442,$P(Y,U),8),U,3),"P",2) Q
I +RVA'<4 S RBL=$P(^PRC(442,$P(Y,U),8),U)-$P(^(8),U,3) W !,"1358 Balance is $",$FN(RBL,"P",2) Q
K RDA,RVA,RBL Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPSC 3515 printed Apr 09, 2024@21:36:20 Page 2
RMPRPSC ;PHX/HNB-PRINT PSC LISTING ;8/29/1994
+1 ;;3.0;PROSTHETICS;;Feb 09, 1996
EN ;entry to Prosthetic Service Card from purchasing
+1 WRITE !!?7,"NAME",?50,"SERIAL NUMBER",!
+2 SET RMPRX=0
FOR I=0:0
SET I=$ORDER(^RMPR(665,RMPRDFN,5,I))
if I'>0
QUIT
DO PRT
+3 READ !!,"SELECT NUMBER: ",RMPRPC:DTIME
IF '$TEST!(RMPRPC["^")
SET RMPRFLG=1
QUIT
+4 IF '$DATA(^RMPR(665,RMPRDFN,5,+RMPRPC,0))
WRITE !?5,$CHAR(7),$CHAR(7),"To obligate funds on this transaction, the veteran must",!?5,"have a PSC issued for that item."
GOTO EN
+5 SET RMPRPI=$PIECE(^RMPR(665,RMPRDFN,5,+RMPRPC,0),U,4)
IF RMPRPI=""
WRITE !,$CHAR(7)
GOTO EN
+6 SET RMPRSR(RMPRPI)=$PIECE(^RMPR(665,RMPRDFN,5,+RMPRPC,0),U,3)
+7 SET RMPRPI=$PIECE(^RMPR(661,RMPRPI,0),U,1)
+8 ;MUST PASS RMPRSR,RMPRPI TO RMPR21 TO POST SERIAL NUMBERS
+9 KILL RMPRX,RMPRIN,RMPRI,RMPRPC
QUIT
+10 ;
PRT ;print items
+1 SET RMPRX=^RMPR(665,RMPRDFN,5,I,0)
SET RMPRI=$PIECE(RMPRX,U,4)
IF RMPRI'=""
SET RMPRIN=$PIECE(^RMPR(661,RMPRI,0),U,1)
SET RMPRIN=$EXTRACT($PIECE(^PRC(441,RMPRIN,0),U,2),1,30)
+2 IF RMPRI'=""
WRITE !,I_".",?7,$SELECT($PIECE(RMPRX,U,2)?1A.E:$PIECE(RMPRX,U,2),1:RMPRIN),?50,$PIECE(RMPRX,U,3)
+3 QUIT
PSC ;ENTRY POINT FOR CREATING PSC ITEMS FOR A PATIENT
+1 SET DIC="^RMPR(665,"
SET DIC(0)="AEQMZ"
DO ^DIC
if +Y'>0
GOTO EXIT
SET RMPRDFN=+Y
DT ;ENTER EDIT PSC CARD
+1 IF '$DATA(^RMPR(665,RMPRDFN,5))
SET ^RMPR(665,RMPRDFN,5,0)="^665.012ID^0^0"
+2 SET DIC="^RMPR(665,"_RMPRDFN_",5,"
SET DIC(0)="AEQMZL"
SET DLAYGO=665
+3 SET DIC("W")="W "" "",$S($P(^(0),U,2)]"""":$E($P(^(0),U,2),1,30),$D(^RMPR(661,+$P(^(0),U,4),0)):$E($P(^PRC(441,$P(^(0),U,1),0),U,2),1,30),1:"""")_"" ""_$P(^RMPR(665,RMPRDFN,5,Y,0),U,3)"
+4 DO ^DIC
KILL DLAYGO
IF +Y'>0
KILL DIC,DIE,DA,Y
if $DATA(RFL)
GOTO EXIT
GOTO PSC
+5 LOCK +^RMPR(665,RMPRDFN,5,+Y):1
IF $TEST=0
WRITE !,?5,$CHAR(7),"Someone is Editing this entry!"
GOTO EXIT
+6 SET DIE=DIC
SET NEW=+$PIECE(Y,U,3)
SET DA(1)=RMPRDFN
SET (DA,RDA)=+Y
SET DR=$SELECT(NEW:".01:1",'NEW:".01:3")
DO ^DIE
LOCK -^RMPR(665,RMPRDFN,5,RDA)
+7 IF '$DATA(^RMPR(665,RMPRDFN,5,RDA,0))
GOTO DT
+8 IF $DATA(^RMPR(665,DA(1),5,DA,0))&'$PIECE(^(0),U,4)
SET DIK="^RMPR(665,"_RMPRDFN_",5,"
SET DA(1)=RMPRDFN
DO ^DIK
WRITE !,?5,$CHAR(7),"Deleted..."
KILL DIE,DIC,DA
GOTO DT
+9 if 'NEW
GOTO DT
SET DR="2:3"
DO ^DIE
GOTO DT
EXIT ;common exit point
+1 if $DATA(RMPRFLAG)
QUIT
KILL DIC,DIE,R90,RDA,DR,NEW
QUIT
EYE ;EDIT FOR EYE GLASSES
+1 ;
+2 SET VENDOR=$$VEN^RMPR31U($PIECE($GET(^RMPR(660.5,+$GET(RMPRDA),0)),U,4))
+3 IF VENDOR="Vendor not found"
SET VENDOR=""
+4 SET DR="4//^S X=VENDOR"
DO ^DIE
KILL VENDOR
+5 IF $DATA(DTOUT)!($DATA(Y)'=0)
GOTO KILL^RMPR21
+6 ;
AA SET X=$PIECE($GET(^RMPR(669.9,RMPRSITE,3)),U,3)
IF X'=""
SET DIC("B")=$$ITM^RMPR31U(X)
+1 KILL DIC,Y
SET DIC=661
SET DIC(0)="AEQMZ"
SET DIC("A")="ITEM (for AMIS): "
SET DIC("S")="S Z=$P(^(0),U,3),R1=$P(^(0),U,4) I +R1>0,+Z>0 I $P(^RMPR(663,+Z,0),U,1)=11!($P(^RMPR(663,+R1,0),U,1)=""R06"")"
DO ^DIC
IF +Y'>0
GOTO KILL^RMPR21
+2 KILL DIC,Y
SET DIC=661
SET DIC(0)="MZ"
SET X="EYEGLASSES"
SET DIC("S")="S R90=$P(^(0),U,3),R1=$P(^(0),U,4) I +R1>0,+R90>0 I $P(^RMPR(663,+R90,0),U,1)=11!($P(^RMPR(663,+R1,0),U,1)=""R06"")"
DO ^DIC
IF +Y'>0
GOTO KILL^RMPR21
+3 KILL DIC,DIE
SET RMPRPI=$PIECE(Y,U,2)
SET DIE="^RMPR(664,"
SET DR="[RMPREYE]"
+4 DO ^DIE
GOTO CHK^RMPR21
PRCS ;ENTRY POINT FOR DISPLAYING 1358 BALANCE
+1 DO EN3^PRCSUT
IF Y=-1
QUIT
+2 KILL PRCS
WRITE !,"Select OBLIGATION NUMBER: ",RMPROB,"// "
READ X:DTIME
if '$TEST
SET X="^"
if X["?"
WRITE !!,?5,"Please Enter '^' to Exit"
if X["^"
QUIT
SET X=$SELECT(X="":RMPROB,1:X)
SET DIC("S")="S RX=^(0) I +RX=+PRC(""SITE""),+$P(RX,U,3)=+PRC(""CP""),+$P(RX,U,2)=21"
+3 SET DIC=442
SET DIC(0)="MQXZ"
DO ^DIC
if +Y'>0
GOTO PRCS
SET RMPROB=$PIECE(Y,U,2)
BAL ;check IFCAP version
+1 SET RDA=$ORDER(^DIC(9.4,"C","PRC",0))
IF $DATA(^DIC(9.4,+RDA,"VERSION"))
SET RVA=+^("VERSION")
+2 IF +RVA<4
WRITE !,"1358 Balance is $",$FNUMBER($PIECE(^PRC(442,$PIECE(Y,U),8),U,3),"P",2)
QUIT
+3 IF +RVA'<4
SET RBL=$PIECE(^PRC(442,$PIECE(Y,U),8),U)-$PIECE(^(8),U,3)
WRITE !,"1358 Balance is $",$FNUMBER(RBL,"P",2)
QUIT
+4 KILL RDA,RVA,RBL
QUIT
