| 1 | RMPRPIYE ;PHX/RFM,RVD-EDIT ISSUE FROM STOCK ;3/8/05 08:04
|
---|
| 2 | ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
|
---|
| 3 | ; RVD #61 - phase III of PIP enhancement.
|
---|
| 4 | ;DBIA #227 - Read access to .01 field of file #445.
|
---|
| 5 | ;DBIA #800 - FILEMAN look up of file #440.
|
---|
| 6 | ;
|
---|
| 7 | EN ;EDIT STOCK ISSUES
|
---|
| 8 | K RMPR6,RMPR11,RMPR11I,RMPR5,RMPR7I,RMPR7,RMPR9,RMPR1
|
---|
| 9 | D HOME^%ZIS,DIV4^RMPRSIT G:$D(X) EXIT^RMPRPIYF
|
---|
| 10 | S DIC("S")="S RM661=$G(^RMPR(660,+Y,1)) I ($P(^RMPR(660,+Y,0),U,13)=11),($P(^(0),U,10)=RMPR(""STA""))"
|
---|
| 11 | ;I RMPRSITE=1 S DIC("S")=DIC("S")_"!($P(^(0),U,10)="""")"
|
---|
| 12 | S DIC="^RMPR(660,",DIC(0)="AEMQ",DIC("A")="Select PATIENT: ",DIC("W")="D ^RMPRD1" D ^DIC G:Y<0 EXIT^RMPRPIYF
|
---|
| 13 | S RMPRIEN=+Y
|
---|
| 14 | L +^RMPR(660,+Y):1 I $T=0 W !,?5,$C(7),"Someone else is Editing this entry!" G EXIT^RMPRPIYF
|
---|
| 15 | S (RMDFN,DFN)=$P(^RMPR(660,+Y,0),U,2)
|
---|
| 16 | S RMPRF=$P(^RMPR(660,+Y,0),U,13)
|
---|
| 17 | INVSE S %X=DIC_+Y_",",%Y="R1(" D %XY^%RCR
|
---|
| 18 | S %X=DIC_+Y_",",%Y="R1BCK(" D %XY^%RCR
|
---|
| 19 | S:'$D(R1(2)) R1(2)="" S:'$D(R1BCK(2)) R1BCK(2)=""
|
---|
| 20 | D DEM^VADPT
|
---|
| 21 | S RMPRNAM=$P(VADM(1),U),RMPRSSN=$P(VADM(2),U)
|
---|
| 22 | S (RMHCPC,RMHCNEW,RMHCOLD)=$P($G(R1(1)),U,4),(RSTCK,REDIT)=1,RMPRCOST=0
|
---|
| 23 | S RMCPT=$P(R1(1),U,6)
|
---|
| 24 | S (RMQNEW,RMQOLD)=$P($G(R1(0)),U,7)
|
---|
| 25 | S (RMLOCNEW,RMLOCOLD,RMITNEW,RMITOLD)=""
|
---|
| 26 | S RMSTOCK=$P($G(R1(1)),U,5)
|
---|
| 27 | I $G(RMSTOCK) S R6612=$G(^RMPR(661.6,RMSTOCK,0)),(RMLOC,RMLOCNEW,RMLOCOLD)=$P(R6612,U,14),(RMIT,RMITNEW,RMITOLD)=$P(R1(2),U,1)
|
---|
| 28 | S R12(0)=R1(0),RMPRREL=$P(R1(0),U,16)
|
---|
| 29 | 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)
|
---|
| 30 | K DIC S R3("D")="",R4("D")=""
|
---|
| 31 | G SET
|
---|
| 32 | ;
|
---|
| 33 | CO ;DISPLAYS STOCK ISSUE
|
---|
| 34 | D CHK^RMPRED5
|
---|
| 35 | D ^RMPRPIYK
|
---|
| 36 | ;
|
---|
| 37 | EDX ;POST
|
---|
| 38 | S DIR(0)="SBO^P:POST;E:EDIT;D:DELETE"
|
---|
| 39 | S DIR("A")="Would 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"
|
---|
| 40 | D ^DIR K DIR G:Y="P" POST^RMPRPIYF G:Y="D" DEL1^RMPRPIYF
|
---|
| 41 | G:Y="E" EDT
|
---|
| 42 | I $D(DIRUT)!$D(DUOUT)!$D(DTOUT) G EXIT^RMPRPIYF
|
---|
| 43 | DEL ;
|
---|
| 44 | S DIR(0)="SBO^E:EDIT;D:DELETE",DIR("B")="E"
|
---|
| 45 | 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
|
---|
| 46 | I $D(DIRUT)!$D(DTOUT)!$D(DUOUT) G EXIT^RMPRPIYF
|
---|
| 47 | I Y="E" G EDT
|
---|
| 48 | I Y="D" G DEL1^RMPRPIYF
|
---|
| 49 | ;
|
---|
| 50 | EDT ;edit patient 2319
|
---|
| 51 | W @IOF,!?30,RMPRNAM,!
|
---|
| 52 | ;
|
---|
| 53 | EDU S RMTY=$P(R1(0),U,4)
|
---|
| 54 | K DIR W ! S DIR(0)="660,2",DIR("B")=$S(RMTY="I":"INITIAL ISSUE",RMTY="X":"REPAIR",RMTY="R":"REPLACE",RMTY="S":"SPARE",1:"")
|
---|
| 55 | 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",1:"")
|
---|
| 56 | 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:"")
|
---|
| 57 | I Y<4 S $P(R1("AM"),U,4)="",$P(R4("D"),U,4)="" G 2
|
---|
| 58 | 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
|
---|
| 59 | 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:"")
|
---|
| 60 | ;
|
---|
| 61 | 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: "
|
---|
| 62 | ;
|
---|
| 63 | HCPCS ;scanning an item is mandatory.
|
---|
| 64 | W ! D SCAN^RMPRPIYS
|
---|
| 65 | I $P(R3("D"),U,6)&((RMPREXC="^")!(RMPREXC="P")) G CO^RMPRPIYE
|
---|
| 66 | I RMPREXC="^" G CO^RMPRPIYE
|
---|
| 67 | I RMPREXC="P" G CO^RMPRPIYE
|
---|
| 68 | I RMPREXC="T" G CO^RMPRPIYE
|
---|
| 69 | I RMPRBARC="",$G(REDIT) G VEN0
|
---|
| 70 | I RMPRBARC="" G HCPCS
|
---|
| 71 | D HCPCS3^RMPRPIY1
|
---|
| 72 | ;set ALL variables based on the scanned label
|
---|
| 73 | S $P(R1(0),U,6)=$G(RMPR11I("ITEM MASTER IEN"))
|
---|
| 74 | S RMPRCOST=0
|
---|
| 75 | I RMPR7("VALUE")>0,RMPR7("QUANTITY")>0 S RMPRCOST=RMPR7("VALUE")/RMPR7("QUANTITY")
|
---|
| 76 | S $P(R1(0),U,16)=RMPRCOST
|
---|
| 77 | S $P(R1(1),U,4)=RMDAHC
|
---|
| 78 | S $P(R1(0),U,14)=RMPR11I("SOURCE")
|
---|
| 79 | G VEN0
|
---|
| 80 | ;
|
---|
| 81 | CPT ;ask for CPT Modifier
|
---|
| 82 | K DIC,Y,RQUIT
|
---|
| 83 | S RDA=RMDAHC_"^"_$P(R1(0),U,4)_"^"_$P(R1(0),U,14)_"^"_660
|
---|
| 84 | D:$D(RMCPT) CHK^RMPRED5
|
---|
| 85 | W:$G(REDIT) !,"OLD CPT MODIFIER: ",$P(R1(1),U,6)
|
---|
| 86 | I RMHCOLD'=RMDAHC D CPT^RMPRCPTU(RDA) G:$D(DUOUT)!$D(DTOUT) CO S $P(R1(1),U,6)=$G(RMCPT) W:$G(REDIT) !,"NEW CPT MODIFIER: ",$G(RMCPT)
|
---|
| 87 | I RMHCOLD'="",(RMHCOLD=RMDAHC),$G(REDIT) D
|
---|
| 88 | .S DIR(0)="Y",DIR("A")="Would you like to Edit CPT MODIFIER Entry ",DIR("B")="N" D ^DIR Q:$D(DTOUT)!$D(DUOUT)
|
---|
| 89 | .I $G(Y) D
|
---|
| 90 | ..S RMCPOLD=RMCPT
|
---|
| 91 | ..D CPT^RMPRCPTU(RDA) Q:$D(DUOUT)!$D(DUOUT) S $P(R1(1),U,6)=$G(RMCPT)
|
---|
| 92 | ..W:RMCPOLD=RMCPT !!,"*** Based on the information given above, CPT Modifier string has not changed!!!",!
|
---|
| 93 | ..W:RMCPOLD'=RMCPT !,"NEW CPT MODIFIER: ",$G(RMCPT)
|
---|
| 94 | K DIR
|
---|
| 95 | ;
|
---|
| 96 | VEN0 ;process vendor
|
---|
| 97 | K DIC,DIR
|
---|
| 98 | S:$D(RMPR6("VENDOR")) DIC("B")=RMPR6("VENDOR")
|
---|
| 99 | S:'$D(RMPR6("VENDOR")) DIC("B")=$P(R1(0),U,9)
|
---|
| 100 | S DIC(0)="AEQM"
|
---|
| 101 | ;S DIC("S")="I $D(RMPRVEN(+Y))"
|
---|
| 102 | S DIC("A")="VENDOR:"
|
---|
| 103 | S DIC="^PRC(440,",DIC(0)="AEQM" D ^DIC I $D(DUOUT)!$D(DTOUT) G CO
|
---|
| 104 | G:+Y<0 VEN0
|
---|
| 105 | S $P(R1(0),U,9)=+Y,$P(R3("D"),U,9)=$P(Y,U,2) K DIR,DIC
|
---|
| 106 | ;
|
---|
| 107 | SOURCE ;
|
---|
| 108 | K DIR S DIR(0)="660,12",DIR("B")=$P(R1(0),U,14),DIR("A")="SOURCE"
|
---|
| 109 | D ^DIR G:$D(DIRUT)!$D(DUOUT) CO^RMPRPIYE G:$D(DTOUT) EXIT^RMPRPIYF
|
---|
| 110 | S $P(R1(0),U,14)=Y,$P(R3("D"),U,14)=$S(Y="C":"Commercial",1:"VA")
|
---|
| 111 | ;
|
---|
| 112 | QTY K DIR S DIR("A")="QUANTITY"
|
---|
| 113 | S DIR(0)="660,5",DIR("B")=$P(R1(0),U,7)
|
---|
| 114 | D ^DIR G:$D(DIRUT)!$D(DUOUT) CO^RMPRPIYE G:$D(DTOUT) EXIT^RMPRPIYF
|
---|
| 115 | I $D(RMUBA),((RMUBA+$P(R1(0),U,7))-Y<0) D LOWBA^RMPRPIYI G HCPCS^RMPRPIYE
|
---|
| 116 | S $P(R1(0),U,7)=Y K DIR
|
---|
| 117 | ;
|
---|
| 118 | CP G ^RMPRPIYF
|
---|
| 119 | ;
|
---|
| 120 | SET ;set the original variables.
|
---|
| 121 | S $P(R3("D"),U,14)=$S($P(R1(0),U,14)="V":"VA",$P(R1(0),U,14)="C":"COMMERCIAL",1:"")
|
---|
| 122 | 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",1:"")
|
---|
| 123 | 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")
|
---|
| 124 | 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:"")
|
---|
| 125 | S RMHCOLD=$P($G(R1(1)),U,4),RMPRPF=$P(R1(0),U,13),RMQOLD=$P(R1(0),U,7)
|
---|
| 126 | S RMSO=$P(R1(0),U,14)
|
---|
| 127 | I $G(RMQOLD),$P($G(R1(0)),U,16) S RMPRCOST=$P(R1(0),U,16)/RMQOLD
|
---|
| 128 | 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
|
---|
| 129 | S Y=$P(R1(1),U,8) G:Y="" CO D DD^%DT S $P(R1("D"),U,8)=Y
|
---|
| 130 | D ^RMPRPIYK G DEL
|
---|
| 131 | Q
|
---|
| 132 | ;
|
---|
| 133 | SET60 ;
|
---|
| 134 | ;RMPR60 -array of data fields for 660 file record.
|
---|
| 135 | S RMPR60("ISSUE TYPE")=$P(R1(0),U,4)
|
---|
| 136 | S RMPR60("IFCAP ITEM")=$P(R1(0),U,6)
|
---|
| 137 | S RMPR60("QUANTITY")=$P(R1(0),U,7)
|
---|
| 138 | S RMPR60("UNIT")=$P(R1(0),U,8)
|
---|
| 139 | S RMPR60("VENDOR IEN")=$P(R1(0),U,9)
|
---|
| 140 | S RMPR60("SERIAL NUM")=$P(R1(0),U,11)
|
---|
| 141 | S RMPR60("DELIV DATE")=$P(R1(0),U,12)
|
---|
| 142 | S RMPR60("DATE OF SERVICE")=$P(R1(1),U,8)
|
---|
| 143 | S RMPR60("SOURCE")=$P(R1(0),U,14)
|
---|
| 144 | S RMPR60("COST")=$P(R1(0),U,16)
|
---|
| 145 | S RMPR60("REMARKS")=$P(R1(0),U,18)
|
---|
| 146 | S RMPR60("LOT NUM")=$P(R1(0),U,24)
|
---|
| 147 | S RMPR60("CPT IEN")=$P(R1(0),U,22)
|
---|
| 148 | S RMPR60("USER")=$P(R1(0),U,27)
|
---|
| 149 | S RMPR60("CPT MOD")=$P(R1(1),U,6)
|
---|
| 150 | S RMPR60("HCPCS")=$P(R1(1),U,4)
|
---|
| 151 | S RMPR60("PAT CAT")=$P(R1("AM"),U,3)
|
---|
| 152 | S RMPR60("SPEC CAT")=$P(R1("AM"),U,4)
|
---|
| 153 | S RMPR60("VENDOR")=$P(R1(0),U,9)
|
---|
| 154 | S:$G(RMDAHC) RMPR60("HCPCS")=RMDAHC
|
---|
| 155 | ;S:$D(RMPR11I("HCPCS")) RMPR60("HCPCS")=RMPR11I("HCPCS")
|
---|
| 156 | S:$D(RMPR11I("ITEM")) RMPR60("ITEM")=RMPR11I("ITEM")
|
---|
| 157 | S:$D(R1("DATE&TIME")) RMPR60("DATE&TIME")=R1("DATE&TIME")
|
---|
| 158 | S RMPR60("VALUE")=RMPR60("COST")
|
---|
| 159 | S:'$D(RMPR11I("STATION")) RMPR11I("STATION")=$G(RMPR("STA"))
|
---|
| 160 | S:$P(R1("AM"),U,3)'=4 RMPR60("SPEC CAT")="@"
|
---|
| 161 | Q
|
---|