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

RMPRED6.m

Go to the documentation of this file. 
  1. RMPRED6 ;PHX/RFM,RVD-EDIT ISSUE FROM STOCK ;9/29/1994
  1.  ;;3.0;PROSTHETICS;**19,33,35,46,41,53,90**;Feb 09, 1996
  1. EN ;EDIT STOCK ISSUES
  1.  D HOME^%ZIS,DIV4^RMPRSIT G:$D(X) EXIT^RMPRED4
  1.  S DIC("S")="I ($P(^(0),U,13)=11!($P(^(0),U,13)=12)) I $P(^(0),U,10)=RMPR(""STA"")" I RMPRSITE=1 S DIC("S")=DIC("S")_"!($P(^(0),U,10)="""")"
  1.  S DIC="^RMPR(660,",DIC(0)="AEMQ",DIC("A")="Select PATIENT: ",DIC("W")="D ^RMPRD1" D ^DIC G:Y<0 EXIT^RMPRED4
  1.  S RMPRIEN=+Y
  1.  L +^RMPR(660,+Y):1 I $T=0 W !,?5,$C(7),"Someone else is Editing this entry!" G EXIT^RMPRED4
  1.  S (RMDFN,DFN)=$P(^RMPR(660,+Y,0),U,2)
  1.  S RMPRF=$P(^RMPR(660,+Y,0),U,13)
  1. INVSE S %X=DIC_+Y_",",%Y="R1(" D %XY^%RCR
  1.  S:'$D(R1(2)) R1(2)=""
  1.  D DEM^VADPT
  1.  S RMPRNAM=$P(VADM(1),U),RMPRSSN=$P(VADM(2),U)
  1.  S (RMHCPC,RMHCNEW,RMHCOLD)=$P($G(R1(1)),U,4),REDIT=1,RMPRUCST=0
  1.  S (RMQNEW,RMQOLD)=$P($G(R1(0)),U,7)
  1.  S (RMLOCNEW,RMLOCOLD,RMITNEW,RMITOLD)=""
  1.  S RMSTOCK=$P($G(R1(1)),U,5)
  1.  I $G(RMSTOCK) S R6612=$G(^RMPR(661.2,RMSTOCK,0)),(RMLOC,RMLOCNEW,RMLOCOLD)=$P(R6612,U,16),(RMIT,RMITNEW,RMITOLD)=$P(R6612,U,9)
  1.  S R12(0)=R1(0),RMPRREL=$P(R1(0),U,16)
  1.  I $D(^RMPR(660,RMPRIEN,1)),+$P(^RMPR(660,RMPRIEN,1),U,3) S (RMPRIP,RIPOLD)=$P(^PRCP(445,$P(^RMPR(660,RMPRIEN,1),U,3),0),U)
  1.  K DIC S R3("D")="",R4("D")=""
  1.  G SET
  1.  ;
  1. CO ;DISPLAYS STOCK ISSUE
  1.  D CHK^RMPRED5
  1.  D NODE2^RMPRSTI
  1.  D ^RMPRST2
  1. EDX ;POST
  1.  S DIR(0)="SBO^P:POST;E:EDIT;D:DELETE"
  1.  S DIR("A")="Woul you like to POST/EDIT/DELETE this entry",DIR("B")="P",DIR("?")="Answer `P` to post the transaction, `E` to edit the transaction,'D' to delete the transaction"
  1.  D ^DIR K DIR G:Y="P" POST^RMPRED4 G:Y="D" DEL1^RMPRED4
  1.  G:Y="E" EDT
  1.  I $D(DIRUT)!$D(DUOUT)!$D(DTOUT) G EXIT^RMPRED4
  1. DEL ;
  1.  S DIR(0)="SBO^E:EDIT;D:DELETE",DIR("B")="E"
  1.  S DIR("A")="Would you like to EDIT/DELETE this Transaction",DIR("?")="Answer 'E' to EDIT the transaction or 'D' to DELETE the transaction." D ^DIR G:$D(DIRUT) EXIT^RMPRED4
  1.  I Y="E" G EDT
  1.  I Y="D" G DEL1^RMPRED4
  1.  ;
  1. EDT ;edit patient 2319
  1.  W @IOF,!?30,RMPRNAM,!
  1.  ;
  1. EDU S RMTY=$P(R1(0),U,4)
  1.  K DIR W ! S DIR(0)="660,2",DIR("B")=$S(RMTY="I":"INITIAL ISSUE",RMTY="X":"REPAIR",RMTY="R":"REPLACE",RMTY="S":"SPARE",RMTY=5:"RENTAL",1:"")
  1.  D ^DIR G:$D(DIRUT) CO S $P(R1(0),U,4)=Y,$P(R3("D"),U,4)=$S(Y="I":"INITIAL ISSUE",Y="X":"REPAIR",Y="R":"REPLACE",Y="S":"SPARE",Y=5:"RENTAL",1:"")
  1.  S DIR(0)="660,62",DIR("B")=$P(R4("D"),U,3) D ^DIR G:$D(DIRUT) CO S $P(R1("AM"),U,3)=Y,$P(R4("D"),U,3)=$S(Y=1:"SC/OP",Y=2:"SC/IP",Y=3:"NSC/IP",Y=4:"NSC/OP",1:"")
  1.  I Y<4 S $P(R1("AM"),U,4)="",$P(R4("D"),U,4)="" G 2
  1.  K DIR I Y=4 S DIR(0)="660,63" S:$P(R1("AM"),U,4)?1N.N DIR("B")=$P(R4("D"),U,4) D ^DIR G:$D(DUOUT)!$D(DTOUT) CO G:$D(DIRUT)!(X="") 2
  1.  I $P(R1("AM"),U,3)=4 S $P(R1("AM"),U,4)=Y,$P(R4("D"),U,4)=$S(Y=1:"SPECIAL LEGISLATION",Y=2:"A&A",Y=3:"PHC",Y=4:"ELIGIBILITY REFORM",1:"")
  1.  ;
  1. 2 S DIC(0)="AEQM",DIC=661 S:$P(R1(0),U,6) DIC("B")=$P(^RMPR(661,$P(R1(0),U,6),0),U) S DIC("A")="ITEM: "
  1.  K DIC("S") D ^DIC
  1.  I $P(R3("D"),U,6)&$D(DUOUT) G CO
  1.  I $D(DUOUT)!$D(DTOUT) G CO
  1.  I +Y'>0 W !!,?5,$C(7),"This is a required response.  Enter '^' to exit",! G 2
  1.  S $P(R1(0),U,6)=+Y,$P(R3("D"),U,6)=$P(Y,U,2) K DIC,Y,X
  1.  ;
  1. LOC ;ask for location
  1.  S (RMITFLG,RMHCFLG,RMHCDA,RMITDA,RMAV,RMAVA,RMCO,RMBAL)=0
  1.  K DIC,Y,X,RQUIT,DTOUT,DUOUT
  1.  S DZ="??",D="B",DIC("S")="I $P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"
  1.  S:RMLOCOLD'="" DIC("B")=RMLOCOLD
  1.  S DIC="^RMPR(661.3,",DIC(0)="AEQM"
  1.  S DIC("A")="Enter Pros Location: " D MIX^DIC1
  1.  I $D(DUOUT)!$D(DTOUT) G CO
  1.  I X="" W !,"This is a mandatory field!!!",! G LOC
  1.  S RMLOC=+Y
  1.  G:'$D(^RMPR(661.3,RMLOC,0)) LOC
  1.  ;
  1. HCPCS ;HCPCS code
  1.  K DIC,RMR,RMX,RQUIT S DIC("A")="PSAS HCPCS: ",DA(1)=RMLOC,RMF=1
  1.  I $P(R1(1),U,4)&(RMLOCOLD=RMLOC) S DIC("B")=$P(R1(1),U,4)
  1.  S DIC="^RMPR(661.3,"_DA(1)_",1,",DIC(0)="AEMNZ"
  1.  S DIC("W")="S RZ=$P(^RMPR(661.3,RMLOC,1,+Y,0),U,1) I RZ W ?30,$P(^RMPR(661.1,RZ,0),U,2)"
  1.  D ^DIC I $D(DUOUT)!$D(DTOUT) G LOC
  1.  I X="" W !,"This is a mandatory field!!!",! G HCPCS
  1.  S (RMHCNEW,RMDAHC)=$P($G(^RMPR(661.3,RMLOC,1,+Y,0)),U,1)
  1.  I $G(RMDAHC),$P(^RMPR(661.1,RMDAHC,0),U,5)'=1 D INACT^RMPRSTI G HCPCS
  1.  S RMHCPC=$P(^RMPR(661.1,RMDAHC,0),U,1),RMHCDA=+Y
  1.  S RDES=$P(^RMPR(661.1,RMDAHC,0),U,2)
  1.  ;
  1. CPT ;ask for CPT Modifier
  1.  K DIC,Y,RQUIT
  1.  S RDA=RMDAHC_"^"_$P(R1(0),U,4)_"^"_$P(R1(0),U,14)_"^"_660
  1.  D:$D(RMCPT) CHK^RMPRED5
  1.  W:$G(REDIT) !,"OLD CPT MODIFIER: ",$P(R1(1),U,6)
  1.  I RMHCOLD'=RMDAHC D CPT^RMPRCPTU(RDA) G:$D(DUOUT)!$D(DTOUT) LIST^RMPRSTE S $P(R1(1),U,6)=$G(RMCPT) W:$G(REDIT) !,"NEW CPT MODIFIER: ",$G(RMCPT)
  1.  I RMHCOLD'="",(RMHCOLD=RMDAHC),$G(REDIT) D
  1.  .S DIR(0)="Y",DIR("A")="Would you like to Edit CPT MODIFIER Entry  ",DIR("B")="N" D ^DIR Q:$D(DTOUT)!$D(DUOUT)
  1.  .I $G(Y) D CPT^RMPRCPTU(RDA) Q:$D(DUOUT)!$D(DUOUT)  S $P(R1(1),U,6)=$G(RMCPT) W !,"NEW CPT MODIFIER: ",$G(RMCPT)
  1.  K DIR
  1.  ;
  1.  ;D ITEM^RMPR5NU1(REDIT,RMLOC,RMLOCOLD,RMDAHC,RMHCOLD,RMHCDA,RMIT)
  1.  ;
  1. ITEM ;ask for PSAS Item to to edit.
  1.  S DA(2)=RMLOC,DA(1)=RMHCDA K DIC,RMU3,RMUBA,RQUIT
  1.  S DIC("A")="Enter PSAS Item: ",DIC(0)="AEMNQ"
  1.  I RMDAHC=RMHCOLD S DIC("B")=$G(RMIT)
  1.  S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
  1.  D ^DIC I $D(DUOUT)!$D(DTOUT) G LOC
  1.  I X="" W !,"This is a mandatory field!!!",! G ITEM
  1.  S RMITDA=+Y,RMU3=$G(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0))
  1.  S RMUBA=$P(RMU3,U,2)
  1.  S (RMITNEW,RMIT)=$P(RMU3,U,1),RMDES=RMIT K DIC("B"),DIC("S")
  1.  I (RMITNEW'=RMITOLD),(RMUBA<1) D LOWBA^RMPRSTI G LOC
  1.  ;
  1.  I $D(RMLOC),$D(RMHCDA),$D(RMITDA) S RMSO=$$SOURCE^RMPR5NU1
  1.  I $D(RMSO),RMSO="" D MESSO^RMPRSTI G LOC
  1.  S:$D(RMSO) $P(R1(0),U,14)=RMSO
  1.  S $P(R3("D"),U,14)=$S(RMSO="C":"COMMERCIAL",RMSO="V":"VA",1:"")
  1.  I $P(R1(1),U,4)'="",$D(DUOUT) G CO
  1.  I $G(RMLOC),'($G(RMHCDA)&$G(RMITDA)) W !,"PSAS Item was not selected!!" G LOC
  1.  I $G(RMLOC),$G(RMHCDA),$G(RMITDA) S RMPRUCST=$$COST^RMPR5NU1
  1.  I '$G(RMPRUCST) D MESSI^RMPRSTI G LOC
  1.  S:$G(REDIT) $P(R1(0),U,16)=RMPRUCST*$P(R1(0),U,7),$P(R3("D"),U,16)=RMPRUCST*$P(R1(0),U,7)
  1.  S $P(R1(1),U,4)=RMDAHC,$P(R1(0),U,22)=$P(^RMPR(661.1,RMDAHC,0),U,4)
  1.  S RMLOCNEW=RMLOC,RMHCNEW=RMDAHC
  1.  D NODE2^RMPRSTI
  1.  K DIC
  1.  ;
  1. VEN0 ;process vendor
  1.  K DIC,DIR
  1.  I $D(RMLOC),$D(RMHCDA),$D(RMITDA) S DIC("B")=$$VEND^RMPR5NU1
  1.  S DIC="^PRC(440,",DIC(0)="AEQM" D ^DIC I $D(DUOUT)!$D(DTOUT) G CO
  1.  G:+Y<0 VEN0
  1.  S $P(R1(0),U,9)=+Y,$P(R3("D"),U,9)=$P(Y,U,2) K DIR,DIC
  1. CP G ^RMPRED4
  1.  ;
  1. SET ;set the original variables.
  1.  S $P(R3("D"),U,14)=$S($P(R1(0),U,14)="V":"VA",$P(R1(0),U,14)="C":"COMMERCIAL",1:"")
  1.  S $P(R3("D"),U,4)=$S($P(R1(0),U,4)="I":"INITIAL ISSUE",$P(R1(0),U,4)="X":"REPAIR",$P(R1(0),U,4)="R":"REPLACE",$P(R1(0),U,4)="S":"SPARE",$P(R1(0),U,4)="5":"RENTAL",1:"")
  1.  S $P(R4("D"),U,3)=$S($P(R1("AM"),U,3)=1:"SC/OP",$P(R1("AM"),U,3)=2:"SC/IP",$P(R1("AM"),U,3)=3:"NSC/IP",$P(R1("AM"),U,3)=4:"NSC/OP")
  1.  S:$P(R1("AM"),U,3)=4&($P(R1("AM"),U,4)) $P(R4("D"),U,4)=$S($P(R1("AM"),U,4)=1:"SPECIAL LEGISLATION",$P(R1("AM"),U,4)=2:"A&A",$P(R1("AM"),U,4)=3:"PHC",$P(R1("AM"),U,4)=4:"ELIGIBILITY REFORM",1:"")
  1.  S RMHCOLD=$P($G(R1(1)),U,4),RMPRPF=$P(R1(0),U,13),RMQOLD=$P(R1(0),U,7)
  1.  S RMSO=$P(R1(0),U,14)
  1.  I $G(RMQOLD),$P($G(R1(0)),U,16) S RMPRUCST=$P(R1(0),U,16)/RMQOLD
  1.  S $P(R3("D"),U,6)=$P(^RMPR(661,$P(R1(0),U,6),0),U,1),RITOLD=$P(R1(0),U,6),RMQOLD=$P(R1(0),U,7),Y=$P(R1(0),U,12) G:Y="" CO D DD^%DT S $P(R3("D"),U,12)=Y
  1.  D ^RMPRST2 G DEL
  1.  Q