Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RMPRPSC

RMPRPSC.m

Go to the documentation of this file.
  1. RMPRPSC ;PHX/HNB-PRINT PSC LISTING ;8/29/1994
  1. ;;3.0;PROSTHETICS;;Feb 09, 1996
  1. EN ;entry to Prosthetic Service Card from purchasing
  1. W !!?7,"NAME",?50,"SERIAL NUMBER",!
  1. S RMPRX=0 F I=0:0 S I=$O(^RMPR(665,RMPRDFN,5,I)) Q:I'>0 D PRT
  1. R !!,"SELECT NUMBER: ",RMPRPC:DTIME I '$T!(RMPRPC["^") S RMPRFLG=1 Q
  1. 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
  1. S RMPRPI=$P(^RMPR(665,RMPRDFN,5,+RMPRPC,0),U,4) I RMPRPI="" W !,$C(7) G EN
  1. S RMPRSR(RMPRPI)=$P(^RMPR(665,RMPRDFN,5,+RMPRPC,0),U,3)
  1. S RMPRPI=$P(^RMPR(661,RMPRPI,0),U,1)
  1. ;MUST PASS RMPRSR,RMPRPI TO RMPR21 TO POST SERIAL NUMBERS
  1. K RMPRX,RMPRIN,RMPRI,RMPRPC Q
  1. ;
  1. PRT ;print items
  1. 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)
  1. I RMPRI'="" W !,I_".",?7,$S($P(RMPRX,U,2)?1A.E:$P(RMPRX,U,2),1:RMPRIN),?50,$P(RMPRX,U,3)
  1. Q
  1. PSC ;ENTRY POINT FOR CREATING PSC ITEMS FOR A PATIENT
  1. S DIC="^RMPR(665,",DIC(0)="AEQMZ" D ^DIC G:+Y'>0 EXIT S RMPRDFN=+Y
  1. DT ;ENTER EDIT PSC CARD
  1. I '$D(^RMPR(665,RMPRDFN,5)) S ^RMPR(665,RMPRDFN,5,0)="^665.012ID^0^0"
  1. S DIC="^RMPR(665,"_RMPRDFN_",5,",DIC(0)="AEQMZL",DLAYGO=665
  1. 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)"
  1. D ^DIC K DLAYGO I +Y'>0 K DIC,DIE,DA,Y G:$D(RFL) EXIT G PSC
  1. L +^RMPR(665,RMPRDFN,5,+Y):1 I $T=0 W !,?5,$C(7),"Someone is Editing this entry!" G EXIT
  1. 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)
  1. I '$D(^RMPR(665,RMPRDFN,5,RDA,0)) G DT
  1. 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
  1. G:'NEW DT S DR="2:3" D ^DIE G DT
  1. EXIT ;common exit point
  1. Q:$D(RMPRFLAG) K DIC,DIE,R90,RDA,DR,NEW Q
  1. EYE ;EDIT FOR EYE GLASSES
  1. ;
  1. S VENDOR=$$VEN^RMPR31U($P($G(^RMPR(660.5,+$G(RMPRDA),0)),U,4))
  1. I VENDOR="Vendor not found" S VENDOR=""
  1. S DR="4//^S X=VENDOR" D ^DIE K VENDOR
  1. I $D(DTOUT)!($D(Y)'=0) G KILL^RMPR21
  1. ;
  1. AA S X=$P($G(^RMPR(669.9,RMPRSITE,3)),U,3) I X'="" S DIC("B")=$$ITM^RMPR31U(X)
  1. 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
  1. 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
  1. K DIC,DIE S RMPRPI=$P(Y,U,2) S DIE="^RMPR(664,",DR="[RMPREYE]"
  1. D ^DIE G CHK^RMPR21
  1. PRCS ;ENTRY POINT FOR DISPLAYING 1358 BALANCE
  1. D EN3^PRCSUT I Y=-1 Q
  1. 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"
  1. S DIC=442,DIC(0)="MQXZ" D ^DIC G:+Y'>0 PRCS S RMPROB=$P(Y,U,2)
  1. BAL ;check IFCAP version
  1. S RDA=$O(^DIC(9.4,"C","PRC",0)) I $D(^DIC(9.4,+RDA,"VERSION")) S RVA=+^("VERSION")
  1. I +RVA<4 W !,"1358 Balance is $",$FN($P(^PRC(442,$P(Y,U),8),U,3),"P",2) Q
  1. 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
  1. K RDA,RVA,RBL Q