- RMPRPIYE ;PHX/RFM,RVD-EDIT ISSUE FROM STOCK ;3/8/05 08:04
- ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
- ; RVD #61 - phase III of PIP enhancement.
- ;DBIA #227 - Read access to .01 field of file #445.
- ;DBIA #800 - FILEMAN look up of file #440.
- ;
- EN ;EDIT STOCK ISSUES
- K RMPR6,RMPR11,RMPR11I,RMPR5,RMPR7I,RMPR7,RMPR9,RMPR1
- D HOME^%ZIS,DIV4^RMPRSIT G:$D(X) EXIT^RMPRPIYF
- 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""))"
- ;I RMPRSITE=1 S DIC("S")=DIC("S")_"!($P(^(0),U,10)="""")"
- S DIC="^RMPR(660,",DIC(0)="AEMQ",DIC("A")="Select PATIENT: ",DIC("W")="D ^RMPRD1" D ^DIC G:Y<0 EXIT^RMPRPIYF
- S RMPRIEN=+Y
- L +^RMPR(660,+Y):1 I $T=0 W !,?5,$C(7),"Someone else is Editing this entry!" G EXIT^RMPRPIYF
- S (RMDFN,DFN)=$P(^RMPR(660,+Y,0),U,2)
- S RMPRF=$P(^RMPR(660,+Y,0),U,13)
- INVSE S %X=DIC_+Y_",",%Y="R1(" D %XY^%RCR
- S %X=DIC_+Y_",",%Y="R1BCK(" D %XY^%RCR
- S:'$D(R1(2)) R1(2)="" S:'$D(R1BCK(2)) R1BCK(2)=""
- D DEM^VADPT
- S RMPRNAM=$P(VADM(1),U),RMPRSSN=$P(VADM(2),U)
- S (RMHCPC,RMHCNEW,RMHCOLD)=$P($G(R1(1)),U,4),(RSTCK,REDIT)=1,RMPRCOST=0
- S RMCPT=$P(R1(1),U,6)
- S (RMQNEW,RMQOLD)=$P($G(R1(0)),U,7)
- S (RMLOCNEW,RMLOCOLD,RMITNEW,RMITOLD)=""
- S RMSTOCK=$P($G(R1(1)),U,5)
- 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)
- S R12(0)=R1(0),RMPRREL=$P(R1(0),U,16)
- 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)
- K DIC S R3("D")="",R4("D")=""
- G SET
- ;
- CO ;DISPLAYS STOCK ISSUE
- D CHK^RMPRED5
- D ^RMPRPIYK
- ;
- EDX ;POST
- S DIR(0)="SBO^P:POST;E:EDIT;D:DELETE"
- 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"
- D ^DIR K DIR G:Y="P" POST^RMPRPIYF G:Y="D" DEL1^RMPRPIYF
- G:Y="E" EDT
- I $D(DIRUT)!$D(DUOUT)!$D(DTOUT) G EXIT^RMPRPIYF
- DEL ;
- S DIR(0)="SBO^E:EDIT;D:DELETE",DIR("B")="E"
- 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
- I $D(DIRUT)!$D(DTOUT)!$D(DUOUT) G EXIT^RMPRPIYF
- I Y="E" G EDT
- I Y="D" G DEL1^RMPRPIYF
- ;
- EDT ;edit patient 2319
- W @IOF,!?30,RMPRNAM,!
- ;
- EDU S RMTY=$P(R1(0),U,4)
- 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:"")
- 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:"")
- 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:"")
- I Y<4 S $P(R1("AM"),U,4)="",$P(R4("D"),U,4)="" G 2
- 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
- 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:"")
- ;
- 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: "
- ;
- HCPCS ;scanning an item is mandatory.
- W ! D SCAN^RMPRPIYS
- I $P(R3("D"),U,6)&((RMPREXC="^")!(RMPREXC="P")) G CO^RMPRPIYE
- I RMPREXC="^" G CO^RMPRPIYE
- I RMPREXC="P" G CO^RMPRPIYE
- I RMPREXC="T" G CO^RMPRPIYE
- I RMPRBARC="",$G(REDIT) G VEN0
- I RMPRBARC="" G HCPCS
- D HCPCS3^RMPRPIY1
- ;set ALL variables based on the scanned label
- S $P(R1(0),U,6)=$G(RMPR11I("ITEM MASTER IEN"))
- S RMPRCOST=0
- I RMPR7("VALUE")>0,RMPR7("QUANTITY")>0 S RMPRCOST=RMPR7("VALUE")/RMPR7("QUANTITY")
- S $P(R1(0),U,16)=RMPRCOST
- S $P(R1(1),U,4)=RMDAHC
- S $P(R1(0),U,14)=RMPR11I("SOURCE")
- G VEN0
- ;
- CPT ;ask for CPT Modifier
- K DIC,Y,RQUIT
- S RDA=RMDAHC_"^"_$P(R1(0),U,4)_"^"_$P(R1(0),U,14)_"^"_660
- D:$D(RMCPT) CHK^RMPRED5
- W:$G(REDIT) !,"OLD CPT MODIFIER: ",$P(R1(1),U,6)
- 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)
- I RMHCOLD'="",(RMHCOLD=RMDAHC),$G(REDIT) D
- .S DIR(0)="Y",DIR("A")="Would you like to Edit CPT MODIFIER Entry ",DIR("B")="N" D ^DIR Q:$D(DTOUT)!$D(DUOUT)
- .I $G(Y) D
- ..S RMCPOLD=RMCPT
- ..D CPT^RMPRCPTU(RDA) Q:$D(DUOUT)!$D(DUOUT) S $P(R1(1),U,6)=$G(RMCPT)
- ..W:RMCPOLD=RMCPT !!,"*** Based on the information given above, CPT Modifier string has not changed!!!",!
- ..W:RMCPOLD'=RMCPT !,"NEW CPT MODIFIER: ",$G(RMCPT)
- K DIR
- ;
- VEN0 ;process vendor
- K DIC,DIR
- S:$D(RMPR6("VENDOR")) DIC("B")=RMPR6("VENDOR")
- S:'$D(RMPR6("VENDOR")) DIC("B")=$P(R1(0),U,9)
- S DIC(0)="AEQM"
- ;S DIC("S")="I $D(RMPRVEN(+Y))"
- S DIC("A")="VENDOR:"
- S DIC="^PRC(440,",DIC(0)="AEQM" D ^DIC I $D(DUOUT)!$D(DTOUT) G CO
- G:+Y<0 VEN0
- S $P(R1(0),U,9)=+Y,$P(R3("D"),U,9)=$P(Y,U,2) K DIR,DIC
- ;
- SOURCE ;
- K DIR S DIR(0)="660,12",DIR("B")=$P(R1(0),U,14),DIR("A")="SOURCE"
- D ^DIR G:$D(DIRUT)!$D(DUOUT) CO^RMPRPIYE G:$D(DTOUT) EXIT^RMPRPIYF
- S $P(R1(0),U,14)=Y,$P(R3("D"),U,14)=$S(Y="C":"Commercial",1:"VA")
- ;
- QTY K DIR S DIR("A")="QUANTITY"
- S DIR(0)="660,5",DIR("B")=$P(R1(0),U,7)
- D ^DIR G:$D(DIRUT)!$D(DUOUT) CO^RMPRPIYE G:$D(DTOUT) EXIT^RMPRPIYF
- I $D(RMUBA),((RMUBA+$P(R1(0),U,7))-Y<0) D LOWBA^RMPRPIYI G HCPCS^RMPRPIYE
- S $P(R1(0),U,7)=Y K DIR
- ;
- CP G ^RMPRPIYF
- ;
- SET ;set the original variables.
- S $P(R3("D"),U,14)=$S($P(R1(0),U,14)="V":"VA",$P(R1(0),U,14)="C":"COMMERCIAL",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",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")
- 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:"")
- S RMHCOLD=$P($G(R1(1)),U,4),RMPRPF=$P(R1(0),U,13),RMQOLD=$P(R1(0),U,7)
- S RMSO=$P(R1(0),U,14)
- I $G(RMQOLD),$P($G(R1(0)),U,16) S RMPRCOST=$P(R1(0),U,16)/RMQOLD
- 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
- S Y=$P(R1(1),U,8) G:Y="" CO D DD^%DT S $P(R1("D"),U,8)=Y
- D ^RMPRPIYK G DEL
- Q
- ;
- SET60 ;
- ;RMPR60 -array of data fields for 660 file record.
- S RMPR60("ISSUE TYPE")=$P(R1(0),U,4)
- S RMPR60("IFCAP ITEM")=$P(R1(0),U,6)
- S RMPR60("QUANTITY")=$P(R1(0),U,7)
- S RMPR60("UNIT")=$P(R1(0),U,8)
- S RMPR60("VENDOR IEN")=$P(R1(0),U,9)
- S RMPR60("SERIAL NUM")=$P(R1(0),U,11)
- S RMPR60("DELIV DATE")=$P(R1(0),U,12)
- S RMPR60("DATE OF SERVICE")=$P(R1(1),U,8)
- S RMPR60("SOURCE")=$P(R1(0),U,14)
- S RMPR60("COST")=$P(R1(0),U,16)
- S RMPR60("REMARKS")=$P(R1(0),U,18)
- S RMPR60("LOT NUM")=$P(R1(0),U,24)
- S RMPR60("CPT IEN")=$P(R1(0),U,22)
- S RMPR60("USER")=$P(R1(0),U,27)
- S RMPR60("CPT MOD")=$P(R1(1),U,6)
- S RMPR60("HCPCS")=$P(R1(1),U,4)
- S RMPR60("PAT CAT")=$P(R1("AM"),U,3)
- S RMPR60("SPEC CAT")=$P(R1("AM"),U,4)
- S RMPR60("VENDOR")=$P(R1(0),U,9)
- S:$G(RMDAHC) RMPR60("HCPCS")=RMDAHC
- ;S:$D(RMPR11I("HCPCS")) RMPR60("HCPCS")=RMPR11I("HCPCS")
- S:$D(RMPR11I("ITEM")) RMPR60("ITEM")=RMPR11I("ITEM")
- S:$D(R1("DATE&TIME")) RMPR60("DATE&TIME")=R1("DATE&TIME")
- S RMPR60("VALUE")=RMPR60("COST")
- S:'$D(RMPR11I("STATION")) RMPR11I("STATION")=$G(RMPR("STA"))
- S:$P(R1("AM"),U,3)'=4 RMPR60("SPEC CAT")="@"
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIYE 7552 printed Apr 23, 2025@18:51:32 Page 2
- RMPRPIYE ;PHX/RFM,RVD-EDIT ISSUE FROM STOCK ;3/8/05 08:04
- +1 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
- +2 ; RVD #61 - phase III of PIP enhancement.
- +3 ;DBIA #227 - Read access to .01 field of file #445.
- +4 ;DBIA #800 - FILEMAN look up of file #440.
- +5 ;
- EN ;EDIT STOCK ISSUES
- +1 KILL RMPR6,RMPR11,RMPR11I,RMPR5,RMPR7I,RMPR7,RMPR9,RMPR1
- +2 DO HOME^%ZIS
- DO DIV4^RMPRSIT
- if $DATA(X)
- GOTO EXIT^RMPRPIYF
- +3 SET DIC("S")="S RM661=$G(^RMPR(660,+Y,1)) I ($P(^RMPR(660,+Y,0),U,13)=11),($P(^(0),U,10)=RMPR(""STA""))"
- +4 ;I RMPRSITE=1 S DIC("S")=DIC("S")_"!($P(^(0),U,10)="""")"
- +5 SET DIC="^RMPR(660,"
- SET DIC(0)="AEMQ"
- SET DIC("A")="Select PATIENT: "
- SET DIC("W")="D ^RMPRD1"
- DO ^DIC
- if Y<0
- GOTO EXIT^RMPRPIYF
- +6 SET RMPRIEN=+Y
- +7 LOCK +^RMPR(660,+Y):1
- IF $TEST=0
- WRITE !,?5,$CHAR(7),"Someone else is Editing this entry!"
- GOTO EXIT^RMPRPIYF
- +8 SET (RMDFN,DFN)=$PIECE(^RMPR(660,+Y,0),U,2)
- +9 SET RMPRF=$PIECE(^RMPR(660,+Y,0),U,13)
- INVSE SET %X=DIC_+Y_","
- SET %Y="R1("
- DO %XY^%RCR
- +1 SET %X=DIC_+Y_","
- SET %Y="R1BCK("
- DO %XY^%RCR
- +2 if '$DATA(R1(2))
- SET R1(2)=""
- if '$DATA(R1BCK(2))
- SET R1BCK(2)=""
- +3 DO DEM^VADPT
- +4 SET RMPRNAM=$PIECE(VADM(1),U)
- SET RMPRSSN=$PIECE(VADM(2),U)
- +5 SET (RMHCPC,RMHCNEW,RMHCOLD)=$PIECE($GET(R1(1)),U,4)
- SET (RSTCK,REDIT)=1
- SET RMPRCOST=0
- +6 SET RMCPT=$PIECE(R1(1),U,6)
- +7 SET (RMQNEW,RMQOLD)=$PIECE($GET(R1(0)),U,7)
- +8 SET (RMLOCNEW,RMLOCOLD,RMITNEW,RMITOLD)=""
- +9 SET RMSTOCK=$PIECE($GET(R1(1)),U,5)
- +10 IF $GET(RMSTOCK)
- SET R6612=$GET(^RMPR(661.6,RMSTOCK,0))
- SET (RMLOC,RMLOCNEW,RMLOCOLD)=$PIECE(R6612,U,14)
- SET (RMIT,RMITNEW,RMITOLD)=$PIECE(R1(2),U,1)
- +11 SET R12(0)=R1(0)
- SET RMPRREL=$PIECE(R1(0),U,16)
- +12 IF $DATA(^RMPR(660,RMPRIEN,1))
- IF +$PIECE(^RMPR(660,RMPRIEN,1),U,3)
- SET (RMPRIP,RIPOLD)=$PIECE(^PRCP(445,$PIECE(^RMPR(660,RMPRIEN,1),U,3),0),U)
- +13 KILL DIC
- SET R3("D")=""
- SET R4("D")=""
- +14 GOTO SET
- +15 ;
- CO ;DISPLAYS STOCK ISSUE
- +1 DO CHK^RMPRED5
- +2 DO ^RMPRPIYK
- +3 ;
- EDX ;POST
- +1 SET DIR(0)="SBO^P:POST;E:EDIT;D:DELETE"
- +2 SET DIR("A")="Would you like to POST/EDIT/DELETE this entry"
- SET DIR("B")="P"
- SET DIR("?")="Answer `P` to post the transaction, `E` to edit the transaction,'D' to delete the transaction"
- +3 DO ^DIR
- KILL DIR
- if Y="P"
- GOTO POST^RMPRPIYF
- if Y="D"
- GOTO DEL1^RMPRPIYF
- +4 if Y="E"
- GOTO EDT
- +5 IF $DATA(DIRUT)!$DATA(DUOUT)!$DATA(DTOUT)
- GOTO EXIT^RMPRPIYF
- DEL ;
- +1 SET DIR(0)="SBO^E:EDIT;D:DELETE"
- SET DIR("B")="E"
- +2 SET DIR("A")="Would you like to EDIT/DELETE this Transaction"
- SET DIR("?")="Answer 'E' to EDIT the transaction or 'D' to DELETE the transaction."
- DO ^DIR
- +3 IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)
- GOTO EXIT^RMPRPIYF
- +4 IF Y="E"
- GOTO EDT
- +5 IF Y="D"
- GOTO DEL1^RMPRPIYF
- +6 ;
- EDT ;edit patient 2319
- +1 WRITE @IOF,!?30,RMPRNAM,!
- +2 ;
- EDU SET RMTY=$PIECE(R1(0),U,4)
- +1 KILL DIR
- WRITE !
- SET DIR(0)="660,2"
- SET DIR("B")=$SELECT(RMTY="I":"INITIAL ISSUE",RMTY="X":"REPAIR",RMTY="R":"REPLACE",RMTY="S":"SPARE",1:"")
- +2 DO ^DIR
- if $DATA(DIRUT)
- GOTO CO
- SET $PIECE(R1(0),U,4)=Y
- SET $PIECE(R3("D"),U,4)=$SELECT(Y="I":"INITIAL ISSUE",Y="X":"REPAIR",Y="R":"REPLACE",Y="S":"SPARE",1:"")
- +3 SET DIR(0)="660,62"
- SET DIR("B")=$PIECE(R4("D"),U,3)
- DO ^DIR
- if $DATA(DIRUT)
- GOTO CO
- SET $PIECE(R1("AM"),U,3)=Y
- SET $PIECE(R4("D"),U,3)=$SELECT(Y=1:"SC/OP",Y=2:"SC/IP",Y=3:"NSC/IP",Y=4:"NSC/OP",1:"")
- +4 IF Y<4
- SET $PIECE(R1("AM"),U,4)=""
- SET $PIECE(R4("D"),U,4)=""
- GOTO 2
- +5 KILL DIR
- IF Y=4
- SET DIR(0)="660,63"
- if $PIECE(R1("AM"),U,4)?1N.N
- SET DIR("B")=$PIECE(R4("D"),U,4)
- DO ^DIR
- if $DATA(DUOUT)!$DATA(DTOUT)
- GOTO CO
- if $DATA(DIRUT)!(X="")
- GOTO 2
- +6 IF $PIECE(R1("AM"),U,3)=4
- SET $PIECE(R1("AM"),U,4)=Y
- SET $PIECE(R4("D"),U,4)=$SELECT(Y=1:"SPECIAL LEGISLATION",Y=2:"A&A",Y=3:"PHC",Y=4:"ELIGIBILITY REFORM",1:"")
- +7 ;
- 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 ;
- HCPCS ;scanning an item is mandatory.
- +1 WRITE !
- DO SCAN^RMPRPIYS
- +2 IF $PIECE(R3("D"),U,6)&((RMPREXC="^")!(RMPREXC="P"))
- GOTO CO^RMPRPIYE
- +3 IF RMPREXC="^"
- GOTO CO^RMPRPIYE
- +4 IF RMPREXC="P"
- GOTO CO^RMPRPIYE
- +5 IF RMPREXC="T"
- GOTO CO^RMPRPIYE
- +6 IF RMPRBARC=""
- IF $GET(REDIT)
- GOTO VEN0
- +7 IF RMPRBARC=""
- GOTO HCPCS
- +8 DO HCPCS3^RMPRPIY1
- +9 ;set ALL variables based on the scanned label
- +10 SET $PIECE(R1(0),U,6)=$GET(RMPR11I("ITEM MASTER IEN"))
- +11 SET RMPRCOST=0
- +12 IF RMPR7("VALUE")>0
- IF RMPR7("QUANTITY")>0
- SET RMPRCOST=RMPR7("VALUE")/RMPR7("QUANTITY")
- +13 SET $PIECE(R1(0),U,16)=RMPRCOST
- +14 SET $PIECE(R1(1),U,4)=RMDAHC
- +15 SET $PIECE(R1(0),U,14)=RMPR11I("SOURCE")
- +16 GOTO VEN0
- +17 ;
- CPT ;ask for CPT Modifier
- +1 KILL DIC,Y,RQUIT
- +2 SET RDA=RMDAHC_"^"_$PIECE(R1(0),U,4)_"^"_$PIECE(R1(0),U,14)_"^"_660
- +3 if $DATA(RMCPT)
- DO CHK^RMPRED5
- +4 if $GET(REDIT)
- WRITE !,"OLD CPT MODIFIER: ",$PIECE(R1(1),U,6)
- +5 IF RMHCOLD'=RMDAHC
- DO CPT^RMPRCPTU(RDA)
- if $DATA(DUOUT)!$DATA(DTOUT)
- GOTO CO
- SET $PIECE(R1(1),U,6)=$GET(RMCPT)
- if $GET(REDIT)
- WRITE !,"NEW CPT MODIFIER: ",$GET(RMCPT)
- +6 IF RMHCOLD'=""
- IF (RMHCOLD=RMDAHC)
- IF $GET(REDIT)
- Begin DoDot:1
- +7 SET DIR(0)="Y"
- SET DIR("A")="Would you like to Edit CPT MODIFIER Entry "
- SET DIR("B")="N"
- DO ^DIR
- if $DATA(DTOUT)!$DATA(DUOUT)
- QUIT
- +8 IF $GET(Y)
- Begin DoDot:2
- +9 SET RMCPOLD=RMCPT
- +10 DO CPT^RMPRCPTU(RDA)
- if $DATA(DUOUT)!$DATA(DUOUT)
- QUIT
- SET $PIECE(R1(1),U,6)=$GET(RMCPT)
- +11 if RMCPOLD=RMCPT
- WRITE !!,"*** Based on the information given above, CPT Modifier string has not changed!!!",!
- +12 if RMCPOLD'=RMCPT
- WRITE !,"NEW CPT MODIFIER: ",$GET(RMCPT)
- End DoDot:2
- End DoDot:1
- +13 KILL DIR
- +14 ;
- VEN0 ;process vendor
- +1 KILL DIC,DIR
- +2 if $DATA(RMPR6("VENDOR"))
- SET DIC("B")=RMPR6("VENDOR")
- +3 if '$DATA(RMPR6("VENDOR"))
- SET DIC("B")=$PIECE(R1(0),U,9)
- +4 SET DIC(0)="AEQM"
- +5 ;S DIC("S")="I $D(RMPRVEN(+Y))"
- +6 SET DIC("A")="VENDOR:"
- +7 SET DIC="^PRC(440,"
- SET DIC(0)="AEQM"
- DO ^DIC
- IF $DATA(DUOUT)!$DATA(DTOUT)
- GOTO CO
- +8 if +Y<0
- GOTO VEN0
- +9 SET $PIECE(R1(0),U,9)=+Y
- SET $PIECE(R3("D"),U,9)=$PIECE(Y,U,2)
- KILL DIR,DIC
- +10 ;
- SOURCE ;
- +1 KILL DIR
- SET DIR(0)="660,12"
- SET DIR("B")=$PIECE(R1(0),U,14)
- SET DIR("A")="SOURCE"
- +2 DO ^DIR
- if $DATA(DIRUT)!$DATA(DUOUT)
- GOTO CO^RMPRPIYE
- if $DATA(DTOUT)
- GOTO EXIT^RMPRPIYF
- +3 SET $PIECE(R1(0),U,14)=Y
- SET $PIECE(R3("D"),U,14)=$SELECT(Y="C":"Commercial",1:"VA")
- +4 ;
- QTY KILL DIR
- SET DIR("A")="QUANTITY"
- +1 SET DIR(0)="660,5"
- SET DIR("B")=$PIECE(R1(0),U,7)
- +2 DO ^DIR
- if $DATA(DIRUT)!$DATA(DUOUT)
- GOTO CO^RMPRPIYE
- if $DATA(DTOUT)
- GOTO EXIT^RMPRPIYF
- +3 IF $DATA(RMUBA)
- IF ((RMUBA+$PIECE(R1(0),U,7))-Y<0)
- DO LOWBA^RMPRPIYI
- GOTO HCPCS^RMPRPIYE
- +4 SET $PIECE(R1(0),U,7)=Y
- KILL DIR
- +5 ;
- CP GOTO ^RMPRPIYF
- +1 ;
- SET ;set the original variables.
- +1 SET $PIECE(R3("D"),U,14)=$SELECT($PIECE(R1(0),U,14)="V":"VA",$PIECE(R1(0),U,14)="C":"COMMERCIAL",1:"")
- +2 SET $PIECE(R3("D"),U,4)=$SELECT($PIECE(R1(0),U,4)="I":"INITIAL ISSUE",$PIECE(R1(0),U,4)="X":"REPAIR",$PIECE(R1(0),U,4)="R":"REPLACE",$PIECE(R1(0),U,4)="S":"SPARE",1:"")
- +3 SET $PIECE(R4("D"),U,3)=$SELECT($PIECE(R1("AM"),U,3)=1:"SC/OP",$PIECE(R1("AM"),U,3)=2:"SC/IP",$PIECE(R1("AM"),U,3)=3:"NSC/IP",$PIECE(R1("AM"),U,3)=4:"NSC/OP")
- +4 if $PIECE(R1("AM"),U,3)=4&($PIECE(R1("AM"),U,4))
- SET $PIECE(R4("D"),U,4)=$SELECT($PIECE(R1("AM"),U,4)=1:"SPECIAL LEGISLATION",$PIECE(R1("AM"),U,4)=2:"A&A",$PIECE(R1("AM"),U,4)=3:"PHC",$PIECE(R1("AM"),U,4)=4:"ELIGIBILITY REFORM",1:"")
- +5 SET RMHCOLD=$PIECE($GET(R1(1)),U,4)
- SET RMPRPF=$PIECE(R1(0),U,13)
- SET RMQOLD=$PIECE(R1(0),U,7)
- +6 SET RMSO=$PIECE(R1(0),U,14)
- +7 IF $GET(RMQOLD)
- IF $PIECE($GET(R1(0)),U,16)
- SET RMPRCOST=$PIECE(R1(0),U,16)/RMQOLD
- +8 SET $PIECE(R3("D"),U,6)=$PIECE(^RMPR(661,$PIECE(R1(0),U,6),0),U,1)
- SET RITOLD=$PIECE(R1(0),U,6)
- SET RMQOLD=$PIECE(R1(0),U,7)
- SET Y=$PIECE(R1(0),U,12)
- if Y=""
- GOTO CO
- DO DD^%DT
- SET $PIECE(R3("D"),U,12)=Y
- +9 SET Y=$PIECE(R1(1),U,8)
- if Y=""
- GOTO CO
- DO DD^%DT
- SET $PIECE(R1("D"),U,8)=Y
- +10 DO ^RMPRPIYK
- GOTO DEL
- +11 QUIT
- +12 ;
- SET60 ;
- +1 ;RMPR60 -array of data fields for 660 file record.
- +2 SET RMPR60("ISSUE TYPE")=$PIECE(R1(0),U,4)
- +3 SET RMPR60("IFCAP ITEM")=$PIECE(R1(0),U,6)
- +4 SET RMPR60("QUANTITY")=$PIECE(R1(0),U,7)
- +5 SET RMPR60("UNIT")=$PIECE(R1(0),U,8)
- +6 SET RMPR60("VENDOR IEN")=$PIECE(R1(0),U,9)
- +7 SET RMPR60("SERIAL NUM")=$PIECE(R1(0),U,11)
- +8 SET RMPR60("DELIV DATE")=$PIECE(R1(0),U,12)
- +9 SET RMPR60("DATE OF SERVICE")=$PIECE(R1(1),U,8)
- +10 SET RMPR60("SOURCE")=$PIECE(R1(0),U,14)
- +11 SET RMPR60("COST")=$PIECE(R1(0),U,16)
- +12 SET RMPR60("REMARKS")=$PIECE(R1(0),U,18)
- +13 SET RMPR60("LOT NUM")=$PIECE(R1(0),U,24)
- +14 SET RMPR60("CPT IEN")=$PIECE(R1(0),U,22)
- +15 SET RMPR60("USER")=$PIECE(R1(0),U,27)
- +16 SET RMPR60("CPT MOD")=$PIECE(R1(1),U,6)
- +17 SET RMPR60("HCPCS")=$PIECE(R1(1),U,4)
- +18 SET RMPR60("PAT CAT")=$PIECE(R1("AM"),U,3)
- +19 SET RMPR60("SPEC CAT")=$PIECE(R1("AM"),U,4)
- +20 SET RMPR60("VENDOR")=$PIECE(R1(0),U,9)
- +21 if $GET(RMDAHC)
- SET RMPR60("HCPCS")=RMDAHC
- +22 ;S:$D(RMPR11I("HCPCS")) RMPR60("HCPCS")=RMPR11I("HCPCS")
- +23 if $DATA(RMPR11I("ITEM"))
- SET RMPR60("ITEM")=RMPR11I("ITEM")
- +24 if $DATA(R1("DATE&TIME"))
- SET RMPR60("DATE&TIME")=R1("DATE&TIME")
- +25 SET RMPR60("VALUE")=RMPR60("COST")
- +26 if '$DATA(RMPR11I("STATION"))
- SET RMPR11I("STATION")=$GET(RMPR("STA"))
- +27 if $PIECE(R1("AM"),U,3)'=4
- SET RMPR60("SPEC CAT")="@"
- +28 QUIT
