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

RMPR4LI.m

Go to the documentation of this file. 
  1. RMPR4LI ;PHX/HNB,RVD-DISPLAY ITEMS ON PURCHASE CARD TRANSACTION ;3/1/1996
  1.  ;;3.0;PROSTHETICS;**3,12,19,20,28,30,41,90,182**;Feb 09, 1996;Build 13
  1.  ;pass RMPRA
  1.  ;
  1.  ;RMPR*3.0*182 Add Contract, Model and Lot number to display
  1.  ;
  1.  S:'$D(RMPRDELN) RMPRDELN="" S (RMPRI,RMPRCNT)=0,RMPRX="" D HOME^%ZIS W @IOF S:'$D(RMPRSER) RMPRSER=""
  1.  W !?5,$G(RMPRSSNE)
  1.  W ?55,"Purchase Card",!
  1.  W ?5,$$STA^RMPRUTIL,"-",$P(^RMPR(664,RMPRA,4),U,5)
  1.  I DUZ=$P(^RMPR(664,RMPRA,0),U,9)!($D(^XUSEC("RMPR FCP MANAGER",DUZ))) W ?55,$$DEC($P(^RMPR(664,RMPRA,4),U,1),$P(^RMPR(664,RMPRA,0),U,9),RMPRA)
  1.  E  W ?55,"encrypted"
  1.  W !
  1.  N RBO S RBO=0
  1.  W !,RMPR("L")
  1. LI F  S RMPRI=$O(^RMPR(664,RMPRA,1,RMPRI)) Q:RMPRI'>0  D  G:$G(RMPRX)["^" EXIT
  1.  .S RMPRCNT=RMPRCNT+1
  1.  .S RMPRI1=^RMPR(664,RMPRA,1,RMPRI,0)
  1.  .D PRT
  1.  I $D(^RMPR(664,RMPRA,1)) W !!,?25,"SUB TOTAL: ",?65,"$",$J(RBO,7,2)
  1.  I $D(^RMPR(664,RMPRA,2)),$P(^(2),U,6) S DCT=$P(^(2),U,6),DCT=DCT/100
  1.  I $D(DCT) D
  1.  .W !!,?25,"% DISCOUNT:  "
  1.  .Q:'$D(DCT)
  1.  .W DCT*100
  1.  .S DCTT=$J(RBO*DCT,7,2)
  1.  .W ?65,"$",DCTT
  1.  .S DCTT=$TR(DCTT," ","")
  1.  .S RBO=RBO-DCTT
  1.  .K DCT,DCTT
  1.  W !?25,"SHIPPING CHARGE: "
  1.  S R2=$S($P(^RMPR(664,RMPRA,0),U,11)]"":$P(^(0),U,11),$P(^(0),U,10):$P(^(0),U,10),1:"") W ?65,"$",$J(R2,7,2) W !
  1.  W !,?25,"TOTAL COST: ",?65,"$",$J(R2+RBO,7,2)
  1.  W !,?5,"BANK AUTHORIZATION: ",$P(^RMPR(664,RMPRA,4),U,2)
  1.  G EXIT
  1. PRT I RMPRCNT<0 W !,"NO ITEMS ON FILE" Q
  1.  W !!?5,"ITEM: "
  1.  S RMPRIT=$P(RMPRI1,U,1),RMPRIT1=$P(^RMPR(661,RMPRIT,0),U,1)
  1.  W $P(^PRC(441,RMPRIT1,0),U,1),"   ",$P(^(0),U,2),"   ",?45,"AMIS: " S RMPRAMIS=$S($P(RMPRI1,U,9)'="X":$P(^RMPR(661,RMPRIT,0),U,3),1:$P(^RMPR(661,RMPRIT,0),U,4))
  1.  W $S(RMPRAMIS="":"NO CODE FOR THIS ITEM",1:$P(^RMPR(663,RMPRAMIS,0),U,1))
  1.  W !,?5,"VENDOR TRACKING: ",$P($G(^RMPR(664,RMPRA,1,RMPRI,4)),U,1)
  1.  S RCPT=$P(^RMPR(664,RMPRA,1,RMPRI,0),U,16)
  1.  S:RCPT RMPRCPT=$G(^RMPR(661.1,RCPT,0))
  1.  I $D(RMPRCPT) W !,?5,"PSAS HCPCS CODE: ",$P(RMPRCPT,U,1),?31,$P(RMPRCPT,U,2)
  1.  K RCPT,RMPRCPT
  1.  W !,?5,"CPT MODIFIER: ",$P($G(^RMPR(664,RMPRA,1,RMPRI,4)),U,2)
  1.  I $P(^RMPR(664,RMPRA,1,RMPRI,0),U,8)'="" W !?5,"REMARKS: ",$P(^(0),U,8)
  1.  I $D(RMPRF),RMPRF=2 W !!?5,"DELIVER TO: ",RMPRDELN
  1.  W !!?5,"DESCRIPTION: ",$P(RMPRI1,U,2)
  1.  W !?5,"CONTRACT #: " S RMPRVAL=$S($P(^RMPR(664,RMPRA,1,RMPRI,0),U,14)]"":$P(^(0),U,14),$D(^RMPR(660,+$P(^(0),U,13),2)):$P(^(2),U,9),1:"") W RMPRVAL  ;RMPR*3*182
  1.  W !?5,"MODEL: " S RMPRVAL=$S($P($G(^RMPR(664,RMPRA,1,RMPRI,2)),U,2)]"":$P(^(2),U,2),$D(^RMPR(660,+$P(^(0),U,13),9)):$P(^(9),U,2),1:"") W RMPRVAL
  1.  W !?5,"SERIAL NUMBER: " S RMPRSER=$S($P(^RMPR(664,RMPRA,1,RMPRI,0),U,15)]"":$P(^(0),U,15),$D(^RMPR(660,+$P(^(0),U,13),0)):$P(^(0),U,11),1:"") W RMPRSER  ;RMPR*3*182
  1.  W !?5,"LOT #: " S RMPRVAL=$S($P($G(^RMPR(664,RMPRA,1,RMPRI,2)),U,3)]"":$P(^(2),U,3),$D(^RMPR(660,+$P(^(0),U,13),0)):$P(^(0),U,24),1:"") W RMPRVAL  ;RMPR*3*182
  1.  ;W !?5,"UNIT COST: ",$J($S($P(RMPRI1,U,7):$P(RMPRI1,U,7),1:$P(RMPRI1,U,3)),0,2),?25,"UNIT OF ISSUE: "
  1.  K RMPRVAL
  1.  W !,?5,"UNIT COST: " S R1=$P(RMPRI1,U,7) S:R1=""!(R1<0) R1=$P(RMPRI1,U,3) W R1,?25,"UNIT OF ISSUE: "
  1.  S RMPRU=$P(RMPRI1,U,5) W:RMPRU'="" $P(^PRCD(420.5,RMPRU,0),U,1),?45,"QTY: ",$P(RMPRI1,U,4),?55,"ITEM COST: "
  1.  ;S R1=$S($P(RMPRI1,U,7):$P(RMPRI1,U,7),1:$P(RMPRI1,U,3)),R2=$P(RMPRI1,U,4),RBO=RBO+(R1*R2) W $J(R1*R2,0,2)
  1.  S R2=$P(RMPRI1,U,4)
  1.  S RBO=RBO+(R1*R2) W $J(R1*R2,0,2)
  1.  W !?5,"TYPE: ",$S($P(RMPRI1,U,9)="X":"REPAIR",$P(RMPRI1,U,9)="I":"INITIAL",$P(RMPRI1,U,9)="R":"REPLACE",$P(RMPRI1,U,9)="S":"SPARE",$P(RMPRI1,U,9)=5:"RENTAL",1:"")
  1.  W ?25,"CATEGORY: ",$S($P(RMPRI1,U,10)=1:"SC/OP",$P(RMPRI1,U,10)=2:"SC/IP",$P(RMPRI1,U,10)=3:"NSC/IP",$P(RMPRI1,U,10)=4:"NSC/OP",1:"")
  1.  W ?44,"SPECIAL CATEGORY: "
  1.  W $S($P(RMPRI1,U,11)=1:"SPEC/LEG",$P(RMPRI1,U,11)=2:"A&A",$P(RMPRI1,U,11)=3:"PHC",$P(RMPRI1,U,11)=4:"ELIGIBILITY REFORM",1:"")
  1. ASK I $Y>17 R !!,"Enter '^' to Quit Display, <Return> to Continue : ",RMPRX:DTIME S:'$T RMPRX="^" Q:RMPRX="^"
  1.  W:$Y>17 @IOF
  1.  Q
  1. EXIT K RMPRI1,R1,R2,ON,OFF Q
  1.  ;
  1. ENC(X,X1,X2) ;encrypt
  1.  ;x is string to encrypt
  1.  ;x1 duz
  1.  ;x2 is ien to file 664
  1.  D EN^XUSHSHP Q X
  1. DEC(X,X1,X2) ;decript
  1.  ;x is encrypted string
  1.  ;x1 is duz
  1.  ;x2 is ien to file 664
  1.  D DE^XUSHSHP Q X
  1.  ;end