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

RMPR29LU.m

Go to the documentation of this file. 
  1. RMPR29LU ;HIN/RVD-LAB ISSUE FROM STOCK UTILITY;5/27/1998
  1.  ;;3.0;PROSTHETICS;**33,37,44**;Feb 09, 1996
  1.  ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. LIS K ^UTILITY("DIQ1",$J),HLD,DIC
  1.  S (RMPRDFN,DFN,Y)=$P(^RMPR(664.1,RMPRDA,0),U,2) D DEM^VADPT
  1.  S RMPRNAM=$P(VADM(1),U),RMPRSSN=$P(VADM(2),U),RMPRDOB=$P(VADM(3),U)
  1.  Q:$G(RMPRDA)'>0  S DIC="^RMPR(664.1,",DA=RMPRDA,DR=".02;.11;.04;.09;2;4;13;15;19"
  1.  D EN^DIQ1 K DIQ,DR S PAGE=1,DA=RMPRDA
  1.  F RI=0:0 S RI=$O(^RMPR(664.1,DA,2,RI)) Q:RI'>0  I $D(^(RI,0)) D
  1.  .S RM6(RI)=$G(^RMPR(664.1,DA,2,RI,0))
  1.  .S DIC="^RMPR(664.1,",DR="6"
  1.  .S DR(664.16)=".01;2;3;8;9;10;7;12;13;14;15;16;17;18",DA(664.16)=RI
  1.  .S HLD(RI)=$$ITM1^RMPR31U($P(^RMPR(664.1,DA,2,RI,0),U))
  1.  .D EN^DIQ1 K DIQ,DR
  1.  I '$D(PNK) D HD^RMPR29W
  1.  I $D(PNK) D HDC^RMPR29W
  1.  S RI=0
  1. ITD ;ITEM DISPLAY
  1.  S RI=$O(HLD(RI)) I '$G(RI)!$G(RMEXIT) K ^UTILITY("DIQ1"),^UTILITY($J),PNK,DIR Q
  1.  W !,HLD(RI),?10,$E(^UTILITY("DIQ1",$J,664.16,RI,.01),1,15)
  1.  W ?27,$E(^UTILITY("DIQ1",$J,664.16,RI,12),1,15),?45,^(2),?50,^(3),?55,^(8),?65,^(9)
  1.  W !,?10,"HCPCS: ",^UTILITY("DIQ1",$J,664.16,RI,13)
  1. WP ;WORD PROCESSING FIELD DISPLAY
  1.  ;D:($Y+8>IOSL) ASK Q:$D(RMEXIT)
  1.  ;S RWP=$O(^UTILITY("DIQ1",$J,664.16,RI,7,0))
  1.  ;I RWP'>0 K HLD(RI) K D0 D ADC^RMPR293(RMPRDA,RI) D  G ITD
  1.  S RLOC=^UTILITY("DIQ1",$J,664.16,RI,17)
  1.  S RGIP=^UTILITY("DIQ1",$J,664.16,RI,18)
  1.  S RMINVF=$S(RLOC'="":"PROS INVENTORY",RGIP'="":"GIP",1:"OTHER")
  1.  W:$D(RMINVF) !,?10,"*** ",RMINVF," ***"
  1.  D:($Y+8>IOSL) ASK
  1.  G ITD
  1.  ;
  1.  ;S X=$G(^UTILITY("DIQ1",$J,664.16,RI,7,RWP))
  1.  ;K ^UTILITY($J) S DIWL=1,DIWR=60,DIWF="R" D ^DIWP Q
  1.  ;
  1. POST I RMPRGIP S PRCP("QTY")=$P(R1(0),U,7)*-1,PRCP("TYP")="R" D ^PRCPUSA
  1.  I $D(PRCP("ITEM")) W !!,"Error encountered while posting to GIP. Inventory Issue did not post..." H 10 S RMEXIT=1 G EXIT
  1.  I RMPRG'="" G GGC
  1.  L +^RMPR(669.9,RMPRSITE,0):999 I $T=0 S RMPRG=DT_99 G GGC
  1.  S RMPRG=$P(^RMPR(669.9,RMPRSITE,0),U,7),RMPRG=RMPRG-1
  1.  S $P(^RMPR(669.9,RMPRSITE,0),U,7)=RMPRG L -^RMPR(669.9,RMPRSITE,0)
  1. GGC S $P(RMPRI("AMS"),U,1)=RMPRG
  1.  S $P(RLB("D"),U,6)=RMTIME,$P(RLB("D"),U,7)=$J(RMLACO,0,2)
  1.  S $P(RLB("D"),U,8)=$J(RMPRCOST,0,2),RMTOTC=RMLACO+RMPRCOST
  1.  S $P(RLB("D"),U,9)=$J(RMTOTC,0,2),$P(RLB("D"),U,11)=DT,RMLAB="Y"
  1.  S RMHCPC=$P(R1(1),U,4),$P(R1(0),U,13)=15,$P(R1(0),U,16)=""
  1.  S RMSER=$P(R1(0),U,11),RMQTY=$P(R1(0),U,7) I $D(RMLOC) D ADD^RMPR5NU1
  1.  W:$D(RMLOC) !!,"Posted to inventory module.."
  1.  ;posting for employee lab item count
  1.  I '$D(RMLOC) D
  1.  .K Y,DD,DO S DIC="^RMPR(661.2,",DIC(0)="L",X=DT,DLAYGO=661.2 D FILE^DICN K DLAYGO S (RM6612,DA)=+Y
  1.  .S ^RMPR(661.2,DA,0)=DT_"^"_RMPRDFN_"^"_RMSO_"^"_RMHCPC_"^^^"_DUZ_"^^"_$P(^RMPR(661.1,RMHCPC,0),U,1)_"^^^^^^"_RMPR("STA")_"^^"
  1.  .S:$D(RMLAB) ^RMPR(661.2,DA,1)=RMTIME_"^"_$J(RMLACO,0,2)
  1.  .S DIK="^RMPR(661.2," D IX1^DIK
  1.  S DIK="^RMPR(660,",(RM660,DA)=+Y D IX1^DIK K DIC W !!,"Posted to 2319..",!
  1.  Q
  1. DEL ;delete status 2529-3
  1.  K DIR,Y
  1.  S DIR(0)="Y",DIR("A")="Would you like to Delete this 2529-3 Entry"
  1.  S DIR("B")="NO" D ^DIR Q:$D(DTOUT)!($D(DUOUT))!(Y=0)
  1.  ;delete entry in the 2319 record and mark entry in 664.1 as deleted
  1.  N BO S BO=0
  1.  F  S BO=$O(^RMPR(664.1,RMPRDA,2,BO)) Q:BO'>0  D
  1.  .S DA=$P(^RMPR(664.1,RMPRDA,2,BO,0),U,5) Q:DA=""
  1.  .S DIK="^RMPR(660," D ^DIK
  1.  W !,?5,"Updated 10-2319" K DA,DIK
  1.  S DIE="^RMPR(664.1,",DA=RMPRDA,DR="16///^S X=""D""" D ^DIE W !,?5,$C(7),"Marked As Deleted..."
  1.  S RDEL=1
  1.  Q
  1. RDL ;delete record
  1.  ;the record is only deleted from 664.1 when the user creats a new
  1.  ;W !! S DIR(0)="Y",DIR("A")="Would you like to delete this Request "
  1.  ;S DIR("B")="NO" D ^DIR Q:$D(DTOUT)!($D(DUOUT))!(Y=0)
  1.  S DA=0,BO=0 Q:$G(REDIT)
  1.  F  S BO=$O(^RMPR(664.1,RMPRDA,2,BO)) Q:BO'>0  D
  1.  .S DA=$P(^RMPR(664.1,RMPRDA,2,BO,0),U,5) Q:DA=""
  1.  .S DIK="^RMPR(660," D ^DIK
  1.  K DIK,DA S DA=RMPRDA,DIK="^RMPR(664.1,"
  1.  D ^DIK K DIK W !!,?5,$C(7),"Deleted..."
  1.  Q
  1.  ;
  1. ASK ;
  1.  K DIR S DIR(0)="E"
  1.  S DIR("A")="Enter 'Return' to view more Items or '^' to QUIT item listing"
  1.  D ^DIR I $D(DTOUT)!$D(DUOUT)!(Y=0) S RMEXIT=1 Q
  1.  W @IOF,RMPR("L")
  1.  Q
  1.  ;
  1. EN4 ;CREATE JOB RECORD
  1.  S RMPR("REF")=$P(^RMPR(664.1,RMPRDA,0),U,4),$P(^(0),U,20)="",RN=+$P(^(0),U,24)
  1.  K DA,D0,DD,DO S DIC="^RMPR(664.2,",DIC(0)="LZ",X=$P(^RMPR(664.1,RMPRDA,0),U,13) D FILE^DICN Q:+Y'>0
  1.  S (RM6642,DA)=+Y,RN=RN+1
  1.  K DIC,Y F RT=0:0 S RT=$O(^RMPR(664.1,RMPRDA,2,RT)) Q:RT'>0  I $D(^(RT,0)) S DA660=$P(^(0),U,5) I +DA660 D  S $P(^RMPR(664.1,RMPRDA,0),U,24)=RN
  1.  .S $P(^RMPR(660,DA660,"LB"),U,5)=RM6642,DA=DA660,DIE="^RMPR(660,",DR="83///^S X=$P(^RMPR(664.1,RMPRDA,0),U,1)" D ^DIE
  1.  S $P(^RMPR(664.2,RM6642,0),U,2)=DA660,$P(^(0),U,3)=RMPR("STA"),$P(^(0),U,4)=RN,$P(^(0),U,8)=RMPR("REF") S DA=RM6642,DIK="^RMPR(664.2," D IX1^DIK
  1.  Q
  1. EXIT ;COMMON EXIT POINT
  1.  D:($Y+8>IOSL) ASK Q:$D(RMEXIT)
  1.  ;S RL=$O(^UTILITY($J,"W",DIWL,0)) I +RL W !,?10,^(RL,0) K ^(0) G EXT
  1.  K ^UTILITY($J)
  1.  Q
  1. HCP(RD0,RD1) ;print HCPCS and GIP or Pros Inventory in -3.
  1.  Q:'$D(^RMPR(664.1,RD0,2,RD1,0))
  1.  S R643=$G(^RMPR(664.1,RD0,2,RD1,3))
  1.  S RPSAITEM=$P(R643,U,3),RPSALOC=$P(R643,U,4)
  1.  S RPHCPC=$P($G(^RMPR(664.1,RD0,2,RD1,2)),U,1)
  1.  Q:'$G(RPHCPC)
  1.  Q:'$D(^RMPR(661.1,RPHCPC,0))
  1.  S RPGIP=$P($G(^RMPR(664.1,RD0,2,RD1,0)),U,13)
  1.  W !,?9,"HCPCS: ",$P(^RMPR(661.1,RPHCPC,0),U,1)
  1.  I $G(RPSALOC),RPSAITEM'="",$D(^RMPR(661.3,RPSALOC,0)) D
  1.  .S RHDA=$O(^RMPR(661.3,RPSALOC,1,"B",RPHCPC,0)) Q:'$G(RHDA)
  1.  .S RIDA=$O(^RMPR(661.3,RPSALOC,1,RHDA,1,"B",RPSAITEM,0))
  1.  .S RIDES=$P($G(^RMPR(661.3,RPSALOC,1,RHDA,1,RIDA,0)),U,8)
  1.  .W ?26,RIDES
  1.  I $G(RPSALOC) W !,?9,"*** Pros Inventory ***",?35,"Location: " I $D(^RMPR(661.3,RPSALOC,0)) W $P(^RMPR(661.3,RPSALOC,0),U,1)
  1.  I '$G(RPSALOC),$G(RPGIP) W !,?9,"*** GIP ***"
  1.  I '$G(RPSALOC),'$G(RPGIP) W !,?9,"*** OTHER ***"
  1.  Q
  1.  ;
  1. CHK ;CHECK DISABILITY AND ITEMS
  1.  ;kill record if not all mandatory fields defined
  1.  K RKILL,RMEXIT,RMEDIT
  1.  F RCK=1,2,3,4,11,15 I $P(^RMPR(664.1,RMPRDA,0),U,RCK)="" S RKILL=1 S DA=RMPRDA,DIK="^RMPR(664.1," D ^DIK W !!,?5,$C(7),"ALL MANDATORY FIELDS NOT DEFINED FORM 2529-3 DELETED" Q
  1.  I $D(RKILL) G EXIT^RMPR29LI
  1.  ;disability code missing
  1.  K DKILL
  1.  I '$D(^RMPR(664.1,RMPRDA,1))!('$O(^RMPR(664.1,RMPRDA,1,0))) S DKILL=1
  1.  F RI=0:0 S RI=$O(^RMPR(664.1,RMPRDA,1,RI)) Q:RI'>0  I $P(^(RI,0),U,1)=""!($P(^(0),U,2)="") S DKILL=1
  1.  ;item missing
  1.  K IKILL
  1.  I '$D(^RMPR(664.1,RMPRDA,2))!('$O(^RMPR(664.1,RMPRDA,2,0))) S IKILL=1
  1.  F RI=0:0 S RI=$O(^RMPR(664.1,RMPRDA,2,RI)) Q:RI'>0  I $P(^(RI,0),U,1)=""!($P(^(0),U,2)="")!($P(^(0),U,4)="")!($P(^(0),U,7)="")!($P(^(0),U,8)="") S IKILL=1
  1. ER1 ;error message
  1.  I $D(DKILL) W $C(7),!!,?5,"2529-3 FORM INCOMPLETE.  DISABILITY CODE INFORMATION IS MISSING!!"
  1.  I $D(IKILL) W $C(7),!!,?5,"2529-3 FORM INCOMPLETE.  ITEM INFORMATION IS MISSING!!"
  1.  I $D(IKILL)!($D(DKILL)) S DIR(0)="Y",DIR("B")="YES" D
  1.  .S DIR("A")="Would you like to EDIT this 2529-3 Entry"
  1.  .D ^DIR I $D(DTOUT)!$D(DUOUT)!(Y=0) S RMEXIT=1 Q
  1.  .S RMEDIT=1
  1.  ;K DA,DIC,DIK,DIWF,DIWL,DIWR,PAGE,PNK,RCK,RI,RL,RWP,X
  1.  ;G LAB^RMPR29LI
  1.  Q