source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPSC.m@ 1397

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