- RMPR29LE ;HIN/RVD-ENTER/CLOSE LAB STOCK ISSUE 2529-3 [ 11/05/98
- ;;3.0;PROSTHETICS;**33,37**;Feb 09,1996
- CREATE ;CREATE Lab Stock Issue 2529-3
- K RMPREDIT,RMPRTMP,RMPR25,RMNEW D DIV4^RMPRSIT G:$D(X) EXIT
- D GETPAT^RMPRUTIL I '$D(RMPRDFN) G EXIT
- S RMDFN=RMPRDFN
- VIEW ;CREATE Lab Stock Issue 2529-3 VIA LAB MENU
- N RMPRDA,RMPRWO,RMPRJOB S RMPRF=15,(RSTOCK,RNEW,RFLG)=1 D ^RMPRPAT
- S DIC="^RMPR(664.1,",DIC(0)="ZL",X=DT
- S DLAYGO=664.1 D FILE^DICN K DLAYGO,DIC G:+Y'>0 EXIT
- S RMPRDA=+Y,$P(^RMPR(664.1,RMPRDA,0),U,2)=RMDFN,$P(^(0),U,3)=RMPR("STA"),$P(^(0),U,17)="S"
- S IDEF=$$STA^RMPR31U(RMPR("STA"))
- S DA=RMPRDA,DIK="^RMPR(664.1," D IX1^DIK
- K DR,DA,DIC,Y,DIE D KVAR^VADPT
- S RMPRDFN=$P(^RMPR(664.1,RMPRDA,0),U,2),VAIP("D")="L"
- D IN5^VADPT S VAINDT=$P($G(VAIP(3)),U) D INP^VADPT
- EDT ;EDIT/DELETE 2529-3
- I $G(RMPRDA)>0,$G(RMPRDA)'="" G TYPE
- K DR,DIC D DIV4^RMPRSIT G:$D(X) EXIT S REDIT=1
- S DIC="^RMPR(664.1,",DIC(0)="AEQM",DR=".01"
- ;screen on complete, delete status
- S DIC("S")="I $P(^(0),U,17)=""S"""
- S DIC("W")="D EN3^RMPRD1"
- K DIC("A") D ^DIC K DIC G:+Y'>0 EXIT S RMPRDA=+Y I $G(RMPRDA)'>0 Q
- L +^RMPR(664.1,RMPRDA,0):1
- I '$T W $C(7),!!,?5,"Someone is already editing this entry" G EXIT
- S RMPRDFN=$P(^RMPR(664.1,RMPRDA,0),U,2)
- D LIS^RMPR29LU K DIR
- S DIR(0)="Y",DIR("A")="Would you like to Edit this Entry",DIR("B")="NO"
- D ^DIR G:$D(DTOUT)!($D(DIRUT)) EXIT G:Y=0!(Y<0) EXIT
- ;D ST^RMPR29LS
- ;
- TYPE ;
- K DIR S PDA=RMPRDA
- D ST^RMPR29LS I '$G(RMPRDFN) W !,"*** UNABLE to access patient information, please contact your IRM..",! G EXIT
- D GD^RMPR29LS
- I $G(RNEW),$D(RMFLG) D RDL^RMPR29LU G:$D(RMFLG) EXIT
- ;G:$D(REDIT) ITEM
- S DIR(0)="SBO^V:VA;C:COMMERCIAL",DIR("A")="Select VA or COMMERCIAL SOURCE" S DIR("B")="C"
- S DIR("?")="Enter V for VA or C for Commercial"
- D ^DIR
- I $D(DUOUT)!$D(DTOUT) D RDL^RMPR29LU G EXIT
- S (RMSOR,RMSO)=Y K DIR
- S DIR(0)="664.16,8"
- TRAN S:$D(RMTYPS) DIR("B")=$S(RMTYPS="I":"INITIAL",RMTYPS="X":"REPAIR",RMTYPS="R":"REPLACE",RMTYPS="S":"SPARE",1:"")
- D ^DIR
- I $D(DUOUT)!$D(DTOUT) D RDL^RMPR29LU G EXIT
- I Y="" W !,"Please enter Type of Transaction!!" G TRAN
- S RMTYP=Y K DIR
- S RMTYPS=$S(Y="I":"INITIAL",Y="X":"REPAIR",Y="R":"REPLACE",Y="S":"SPARE",1:"")
- PCAT K DIR S DIR(0)="664.16,9" S:$D(RMCATS) DIR("B")=$S(RMCATS=1:"SC/OP",RMCATS=2:"SC/IP",RMCATS=3:"NSC/IP",RMCATS=4:"NSC/OP",1:"")
- D ^DIR
- I $D(DUOUT)!$D(DTOUT) D RDL^RMPR29LU G EXIT
- I Y="" W !,"Please enter Patient Category!!" G PCAT
- S RMCAT=Y,RMCATS=$S(Y=1:"SC/OP",Y=2:"SC/IP",Y=3:"NSC/IP",Y=4:"NSC/OP",1:"") K DIR G:RMCAT<4 ITEM
- SCAT S DIR(0)="664.16,10" S:$D(RMSPES) DIR("B")=$S(RMSPES=1:"SPECIAL LEGISLATION",RMSPES=2:"A&A",RMSPES=3:"PHC",RMSPES=4:"ELIGIBILITY REFORM",1:"")
- I RMCAT=4 D ^DIR I $D(DUOUT)!$D(DTOUT) D RDL^RMPR29LU G EXIT
- I RMCAT=4 S RMSPE=Y,RMSPES=$S(Y=1:"SPECIAL LEGISLATION",Y=2:"A&A",Y=3:"PHC",Y=4:"ELIGIBILITY REFORM",1:"")
- K DIR
- ITEM ;EDIT 2529-3 ITEM
- K DIR,RMEDIT,RMITFLG,DUOUT,DTOUT,DIC,RMPRGIP,RDEL S DA=RMPRDA,DIC="^RMPR(664.1,"_RMPRDA_",2,"
- S DIC("P")="664.16PA",DA(1)=RMPRDA,DIC(0)="AEQMZL"
- D ^DIC K DIC G:+Y'>0 LAB
- S RMITEMS=$P($G(^RMPR(661,$P(Y,U,2),0)),U,1)
- S (RMIDA,DA)=+Y,DIE="^RMPR(664.1,"_RMPRDA_",2,",DR=".01" D ^DIE I $D(Y)!'$D(^RMPR(664.1,RMPRDA,2,RMIDA,0)) D G ITEM
- .K ^RMPR(664.1,RMPRDA,2,RMIDA) K DIE,DR,RMIDA S RICHECK=$O(^RMPR(664.1,RMPRDA,2,0))
- .K:'$G(RICHECK) REDIT
- I $D(^RMPR(664.1,RMPRDA,2,RMIDA,0)),$P(^RMPR(664.1,RMPRDA,2,RMIDA,0),U,1)="" K ^RMPR(664.1,RMPRDA,2,RMIDA) G ITEM
- S RM0=$G(^RMPR(664.1,RMPRDA,2,DA,0)) S:$P(RM0,U,2)'="" REDIT=1
- I $G(REDIT) D
- .S RMHS=$P($G(^RMPR(664.1,RMPRDA,2,DA,2)),U,1)
- .S RM3=$G(^RMPR(664.1,RMPRDA,2,DA,3)),RMLOC=$P(RM3,U,4),RMIT=$P(RM3,U,3)
- .S RMQTYS=$P(RM0,U,2),RMCOS=$P(RM0,U,4),RMGIP=$P(RM0,U,13)
- .S RMTYPS=$P(RM0,U,7),RMCATS=$P(RM0,U,8),RMSPES=$P(RM0,U,9)
- HCPCS ;HCPCS code
- K DIC
- S DIC(0)="AQEM",DIC="^RMPR(661.1,",DIC("A")="PSAS HCPCS: " S:$G(RMHS) DIC("B")=RMHS
- S DIC("S")="I $P(^RMPR(661.1,+Y,0),U,10)"
- D ^DIC
- I $D(DUOUT)!$D(DTOUT) G:$G(REDIT) LAB D RDL^RMPR29LU G EXIT
- I Y=-1 W !,"HCPCS CODE IS MANDATORY!" D HELP G HCPCS
- I $P(^RMPR(661.1,+Y,0),U,10)<1 D HELP G HCPCS
- I +Y>0 G:$P(^RMPR(661.1,+Y,0),U,5)'=1 HCPCS S $P(R1(0),U,22)=$P(^RMPR(661.1,+Y,0),U,4)
- S (RMI,RMHCPC,DA(1),RMHCPCS)=+Y
- D ITEMLOC^RMPR5NU1 K DIC
- I $G(RMITFLG) G:$G(REDIT) LAB D RDL^RMPR29LU G EXIT
- K:'$G(RMHCDA)!'$G(RMITDA) RMLOC I $G(RMLOC) S RMGIP=0 G VEN
- G GI
- HMESS1 W !,$C(7),"HCPCS has no pre-determined time....",!,"Please SEND mail message to G.PROS-CODE@DOMAIN.EXT!!!" X CK Q
- Q
- ;
- GI I $P(^RMPR(669.9,RMPRSITE,0),U,3),'$D(^PRCP(445,"AD",DUZ)) W $C(7),!,"You are not an authorized user of any Inventory Point, please see your ADPAC." H 2 D RDL^RMPR29LU G EXIT
- S RMPRGIP=$P(^RMPR(669.9,RMPRSITE,0),U,3),RMFORM=15 I RMPRGIP S PRCPPRIV=1 D INV^RMPR29LS G:$D(RMEXIT)&($G(REDIT)) LAB Q:$D(RMEXIT)
- G:$D(RDEL) ITEM
- ;
- VEN K DIC("S")
- ;S X=" ",DIC=440,DIC(0)="ZM" D ^DIC S:+Y>0 DIC("B")=$P(^PRC(440,+Y,0),U,1)
- VEN0 I $G(RMLOC),$D(RMVEN) S DIC("B")=RMVEN
- S DIC(0)="AEQM",DIC=440,DIC("A")="VENDOR: " S:$G(REDIT)&($D(RMVENS)) DIC("B")=RMVENS D ^DIC
- I $D(DUOUT)!$D(DTOUT) G:$G(REDIT) LAB D RDL^RMPR29LU G EXIT
- I +Y'>0 W !!,?5,$C(7),"This is a required response. Enter '^' to exit",! G VEN
- S (RMVEN,RMVENS)=+Y K DIC,Y,X
- COS ;UNIT COST
- I (RMSO["C")&($G(RMPRGIP)) S RMCOS=$P($G(^PRCP(445,PRCP("I"),1,PRCP("ITEM"),0)),U,15)
- I $G(RMLOC) S RMCOS=$P($G(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0)),U,10)
- S DIR(0)="667.3,3",DIR("A")="UNIT COST"
- S:$D(RMCOS)&($G(RMCOS)) DIR("B")=RMCOS
- D ^DIR K DIR
- I $D(DUOUT)!$D(DTOUT) G:$G(REDIT) LAB D RDL^RMPR29LU G EXIT
- I (RMSO["C")&(X<.001) W !,"You must enter a UNIT COST....",! G COS
- S RMCO=Y K DIR
- QTY S DIR(0)="664.16,2",RMQTYS=$P(RM0,U,2) S:$D(RMQTYS) DIR("B")=RMQTYS D ^DIR
- I $D(DUOUT)!$D(DTOUT) G:$G(REDIT) LAB D RDL^RMPR29LU G EXIT
- I X<1 W !,"You must enter a quantity....",! G QTY
- S (RMQTY,RMQTYS)=Y K DIR
- ;
- K DIR S DIR(0)="664.16,12",RMSERS=$P(RM0,U,12) S:$D(RMSERS) DIR("B")=RMSERS D ^DIR
- I $D(DUOUT)!$D(DTOUT) G:$G(REDIT) LAB D RDL^RMPR29LU G EXIT
- S (RMSER,RMSERS)=Y K DIR
- S DIE(0)="AEQM",DR=4
- S DR(1,664.129)="4;"
- S DR(2,664.1294)=".01"
- S ^RMPR(664.1,RMPRDA,8,0)="^664.129DA"
- S ^RMPR(664.1,RMPRDA,8,1,1,0)="^664.1294^"
- S DA(1)=RMPRDA,DIE="^RMPR(664.1,"_RMPRDA_",8,"
- S DA=1 D ^DIE K DIE,DR,DA
- S DA(1)=RMPRDA,DA=RMIDA,DIE="^RMPR(664.1,"_RMPRDA_",2,"
- S DR="2///^S X=$G(RMQTY);4///^S X=$G(RMCO);12///^S X=$G(RMSER);8///^S X=$G(RMTYP);9///^S X=$G(RMCAT);10///^S X=$G(RMSPE);16///^S X=$G(RMIT);14///^S X=$G(RMSO)"
- D ^DIE I $D(DTOUT)!$D(DUOUT) G:$G(REDIT) LAB G EXIT
- S RM0=$G(^RMPR(664.1,RMPRDA,2,DA,0)),RMQTY=$P(RM0,U,2),RMCO=$P(RM0,U,4)
- I RMQTY S RMTOCO=RMQTY*RMCO,DR="11///^S X=$G(RMTOCO);13///^S X=$G(RMHCPC)" D ^DIE
- S:$G(RMGIP) $P(^RMPR(664.1,RMPRDA,2,DA,0),U,13)=RMGIP
- S $P(^RMPR(664.1,RMPRDA,2,DA,3),U,4)=$G(RMLOC)
- S $P(^RMPR(664.1,RMPRDA,2,DA,3),U,2)=$G(RMVEN)
- G ITEM
- LAB ;ASK TO POST REQUEST
- I $G(REDIT),$D(RMIDA) D SET^RMPR29LS
- S DIR(0)="Y",DIR("A")="Would you like to review this request"
- S DIR("B")="YES" D ^DIR I $D(DTOUT)!($D(DUOUT)) D CHK^RMPR29LU D:$G(RMEXIT) RDL^RMPR29LU G EXIT
- I Y=1 S IOP="HOME" D PRT^RMPR29R
- D CHK^RMPR29LU K RMNEW G:$G(RMEDIT) TYPE D:$G(RMEXIT) RDL^RMPR29LU G:$G(RMEXIT) EXIT
- K DIR S DIR(0)="Y",DIR("A")="Would you like to post this request"
- S DIR("B")="YES" D ^DIR G:$D(DTOUT)!($D(DUOUT)) EXIT
- I +Y=0 W !!,?5,$C(7),"Request not posted!!" D RDL^RMPR29LU G EXIT
- S RMPRWO=$P(^RMPR(664.1,RMPRDA,0),U,13) G:RMPRWO'="" PRINT S SCR=$P(^(0),U,11)
- D CR^RMPR29U(SCR) I '$D(RMPRWO) W !!,?5,$C(7),"Request not posted!!" D RDL^RMPR29LU G EXIT
- PRINT D SG^RMPR29LS
- S DIK="^RMPR(664.1,",DA=RMPRDA D IX1^DIK K DIK,DA
- W !! S DIR(0)="Y",DIR("A")="Would you like to print this 2529-3 request"
- S DIR("B")="YES" D ^DIR G:$D(DTOUT)!($D(DUOUT)) EXIT I Y=1 D PRT^RMPR29R
- ;close a Lab Issue from Stock.
- D STA^RMPR29LC
- ;suspense record inquiry
- D LINK^RMPRS
- G CREATE
- HELP ;
- W !,"** You can only select HCPCS that have a LAB pre-determined time.",!,"** If the HCPCS you are selecting are not in the list, please send an E-mail"
- W !,"** message to G.PROS-CODE@DOMAIN.EXT to be added in the list..."
- Q
- ;
- EXIT ;common exit
- L:+$G(RMPRDA) -^RMPR(664.1,+RMPRDA,0)
- ;I '$D(RMPR25)&('$D(RMPREDIT)) W !! S DIR(0)="Y",DIR("A")="Would you like to Process another 2529-3 Request",DIR("B")="NO" D ^DIR G:+Y=1 CREATE
- N RMPR,RMPRSITE D KILL^XUSCLEAN
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR29LE 8492 printed Apr 23, 2025@18:46:47 Page 2
- RMPR29LE ;HIN/RVD-ENTER/CLOSE LAB STOCK ISSUE 2529-3 [ 11/05/98
- +1 ;;3.0;PROSTHETICS;**33,37**;Feb 09,1996
- CREATE ;CREATE Lab Stock Issue 2529-3
- +1 KILL RMPREDIT,RMPRTMP,RMPR25,RMNEW
- DO DIV4^RMPRSIT
- if $DATA(X)
- GOTO EXIT
- +2 DO GETPAT^RMPRUTIL
- IF '$DATA(RMPRDFN)
- GOTO EXIT
- +3 SET RMDFN=RMPRDFN
- VIEW ;CREATE Lab Stock Issue 2529-3 VIA LAB MENU
- +1 NEW RMPRDA,RMPRWO,RMPRJOB
- SET RMPRF=15
- SET (RSTOCK,RNEW,RFLG)=1
- DO ^RMPRPAT
- +2 SET DIC="^RMPR(664.1,"
- SET DIC(0)="ZL"
- SET X=DT
- +3 SET DLAYGO=664.1
- DO FILE^DICN
- KILL DLAYGO,DIC
- if +Y'>0
- GOTO EXIT
- +4 SET RMPRDA=+Y
- SET $PIECE(^RMPR(664.1,RMPRDA,0),U,2)=RMDFN
- SET $PIECE(^(0),U,3)=RMPR("STA")
- SET $PIECE(^(0),U,17)="S"
- +5 SET IDEF=$$STA^RMPR31U(RMPR("STA"))
- +6 SET DA=RMPRDA
- SET DIK="^RMPR(664.1,"
- DO IX1^DIK
- +7 KILL DR,DA,DIC,Y,DIE
- DO KVAR^VADPT
- +8 SET RMPRDFN=$PIECE(^RMPR(664.1,RMPRDA,0),U,2)
- SET VAIP("D")="L"
- +9 DO IN5^VADPT
- SET VAINDT=$PIECE($GET(VAIP(3)),U)
- DO INP^VADPT
- EDT ;EDIT/DELETE 2529-3
- +1 IF $GET(RMPRDA)>0
- IF $GET(RMPRDA)'=""
- GOTO TYPE
- +2 KILL DR,DIC
- DO DIV4^RMPRSIT
- if $DATA(X)
- GOTO EXIT
- SET REDIT=1
- +3 SET DIC="^RMPR(664.1,"
- SET DIC(0)="AEQM"
- SET DR=".01"
- +4 ;screen on complete, delete status
- +5 SET DIC("S")="I $P(^(0),U,17)=""S"""
- +6 SET DIC("W")="D EN3^RMPRD1"
- +7 KILL DIC("A")
- DO ^DIC
- KILL DIC
- if +Y'>0
- GOTO EXIT
- SET RMPRDA=+Y
- IF $GET(RMPRDA)'>0
- QUIT
- +8 LOCK +^RMPR(664.1,RMPRDA,0):1
- +9 IF '$TEST
- WRITE $CHAR(7),!!,?5,"Someone is already editing this entry"
- GOTO EXIT
- +10 SET RMPRDFN=$PIECE(^RMPR(664.1,RMPRDA,0),U,2)
- +11 DO LIS^RMPR29LU
- KILL DIR
- +12 SET DIR(0)="Y"
- SET DIR("A")="Would you like to Edit this Entry"
- SET DIR("B")="NO"
- +13 DO ^DIR
- if $DATA(DTOUT)!($DATA(DIRUT))
- GOTO EXIT
- if Y=0!(Y<0)
- GOTO EXIT
- +14 ;D ST^RMPR29LS
- +15 ;
- TYPE ;
- +1 KILL DIR
- SET PDA=RMPRDA
- +2 DO ST^RMPR29LS
- IF '$GET(RMPRDFN)
- WRITE !,"*** UNABLE to access patient information, please contact your IRM..",!
- GOTO EXIT
- +3 DO GD^RMPR29LS
- +4 IF $GET(RNEW)
- IF $DATA(RMFLG)
- DO RDL^RMPR29LU
- if $DATA(RMFLG)
- GOTO EXIT
- +5 ;G:$D(REDIT) ITEM
- +6 SET DIR(0)="SBO^V:VA;C:COMMERCIAL"
- SET DIR("A")="Select VA or COMMERCIAL SOURCE"
- SET DIR("B")="C"
- +7 SET DIR("?")="Enter V for VA or C for Commercial"
- +8 DO ^DIR
- +9 IF $DATA(DUOUT)!$DATA(DTOUT)
- DO RDL^RMPR29LU
- GOTO EXIT
- +10 SET (RMSOR,RMSO)=Y
- KILL DIR
- +11 SET DIR(0)="664.16,8"
- TRAN if $DATA(RMTYPS)
- SET DIR("B")=$SELECT(RMTYPS="I":"INITIAL",RMTYPS="X":"REPAIR",RMTYPS="R":"REPLACE",RMTYPS="S":"SPARE",1:"")
- +1 DO ^DIR
- +2 IF $DATA(DUOUT)!$DATA(DTOUT)
- DO RDL^RMPR29LU
- GOTO EXIT
- +3 IF Y=""
- WRITE !,"Please enter Type of Transaction!!"
- GOTO TRAN
- +4 SET RMTYP=Y
- KILL DIR
- +5 SET RMTYPS=$SELECT(Y="I":"INITIAL",Y="X":"REPAIR",Y="R":"REPLACE",Y="S":"SPARE",1:"")
- PCAT KILL DIR
- SET DIR(0)="664.16,9"
- if $DATA(RMCATS)
- SET DIR("B")=$SELECT(RMCATS=1:"SC/OP",RMCATS=2:"SC/IP",RMCATS=3:"NSC/IP",RMCATS=4:"NSC/OP",1:"")
- +1 DO ^DIR
- +2 IF $DATA(DUOUT)!$DATA(DTOUT)
- DO RDL^RMPR29LU
- GOTO EXIT
- +3 IF Y=""
- WRITE !,"Please enter Patient Category!!"
- GOTO PCAT
- +4 SET RMCAT=Y
- SET RMCATS=$SELECT(Y=1:"SC/OP",Y=2:"SC/IP",Y=3:"NSC/IP",Y=4:"NSC/OP",1:"")
- KILL DIR
- if RMCAT<4
- GOTO ITEM
- SCAT SET DIR(0)="664.16,10"
- if $DATA(RMSPES)
- SET DIR("B")=$SELECT(RMSPES=1:"SPECIAL LEGISLATION",RMSPES=2:"A&A",RMSPES=3:"PHC",RMSPES=4:"ELIGIBILITY REFORM",1:"")
- +1 IF RMCAT=4
- DO ^DIR
- IF $DATA(DUOUT)!$DATA(DTOUT)
- DO RDL^RMPR29LU
- GOTO EXIT
- +2 IF RMCAT=4
- SET RMSPE=Y
- SET RMSPES=$SELECT(Y=1:"SPECIAL LEGISLATION",Y=2:"A&A",Y=3:"PHC",Y=4:"ELIGIBILITY REFORM",1:"")
- +3 KILL DIR
- ITEM ;EDIT 2529-3 ITEM
- +1 KILL DIR,RMEDIT,RMITFLG,DUOUT,DTOUT,DIC,RMPRGIP,RDEL
- SET DA=RMPRDA
- SET DIC="^RMPR(664.1,"_RMPRDA_",2,"
- +2 SET DIC("P")="664.16PA"
- SET DA(1)=RMPRDA
- SET DIC(0)="AEQMZL"
- +3 DO ^DIC
- KILL DIC
- if +Y'>0
- GOTO LAB
- +4 SET RMITEMS=$PIECE($GET(^RMPR(661,$PIECE(Y,U,2),0)),U,1)
- +5 SET (RMIDA,DA)=+Y
- SET DIE="^RMPR(664.1,"_RMPRDA_",2,"
- SET DR=".01"
- DO ^DIE
- IF $DATA(Y)!'$DATA(^RMPR(664.1,RMPRDA,2,RMIDA,0))
- Begin DoDot:1
- +6 KILL ^RMPR(664.1,RMPRDA,2,RMIDA)
- KILL DIE,DR,RMIDA
- SET RICHECK=$ORDER(^RMPR(664.1,RMPRDA,2,0))
- +7 if '$GET(RICHECK)
- KILL REDIT
- End DoDot:1
- GOTO ITEM
- +8 IF $DATA(^RMPR(664.1,RMPRDA,2,RMIDA,0))
- IF $PIECE(^RMPR(664.1,RMPRDA,2,RMIDA,0),U,1)=""
- KILL ^RMPR(664.1,RMPRDA,2,RMIDA)
- GOTO ITEM
- +9 SET RM0=$GET(^RMPR(664.1,RMPRDA,2,DA,0))
- if $PIECE(RM0,U,2)'=""
- SET REDIT=1
- +10 IF $GET(REDIT)
- Begin DoDot:1
- +11 SET RMHS=$PIECE($GET(^RMPR(664.1,RMPRDA,2,DA,2)),U,1)
- +12 SET RM3=$GET(^RMPR(664.1,RMPRDA,2,DA,3))
- SET RMLOC=$PIECE(RM3,U,4)
- SET RMIT=$PIECE(RM3,U,3)
- +13 SET RMQTYS=$PIECE(RM0,U,2)
- SET RMCOS=$PIECE(RM0,U,4)
- SET RMGIP=$PIECE(RM0,U,13)
- +14 SET RMTYPS=$PIECE(RM0,U,7)
- SET RMCATS=$PIECE(RM0,U,8)
- SET RMSPES=$PIECE(RM0,U,9)
- End DoDot:1
- HCPCS ;HCPCS code
- +1 KILL DIC
- +2 SET DIC(0)="AQEM"
- SET DIC="^RMPR(661.1,"
- SET DIC("A")="PSAS HCPCS: "
- if $GET(RMHS)
- SET DIC("B")=RMHS
- +3 SET DIC("S")="I $P(^RMPR(661.1,+Y,0),U,10)"
- +4 DO ^DIC
- +5 IF $DATA(DUOUT)!$DATA(DTOUT)
- if $GET(REDIT)
- GOTO LAB
- DO RDL^RMPR29LU
- GOTO EXIT
- +6 IF Y=-1
- WRITE !,"HCPCS CODE IS MANDATORY!"
- DO HELP
- GOTO HCPCS
- +7 IF $PIECE(^RMPR(661.1,+Y,0),U,10)<1
- DO HELP
- GOTO HCPCS
- +8 IF +Y>0
- if $PIECE(^RMPR(661.1,+Y,0),U,5)'=1
- GOTO HCPCS
- SET $PIECE(R1(0),U,22)=$PIECE(^RMPR(661.1,+Y,0),U,4)
- +9 SET (RMI,RMHCPC,DA(1),RMHCPCS)=+Y
- +10 DO ITEMLOC^RMPR5NU1
- KILL DIC
- +11 IF $GET(RMITFLG)
- if $GET(REDIT)
- GOTO LAB
- DO RDL^RMPR29LU
- GOTO EXIT
- +12 if '$GET(RMHCDA)!'$GET(RMITDA)
- KILL RMLOC
- IF $GET(RMLOC)
- SET RMGIP=0
- GOTO VEN
- +13 GOTO GI
- HMESS1 WRITE !,$CHAR(7),"HCPCS has no pre-determined time....",!,"Please SEND mail message to G.PROS-CODE@DOMAIN.EXT!!!"
- XECUTE CK
- QUIT
- +1 QUIT
- +2 ;
- GI IF $PIECE(^RMPR(669.9,RMPRSITE,0),U,3)
- IF '$DATA(^PRCP(445,"AD",DUZ))
- WRITE $CHAR(7),!,"You are not an authorized user of any Inventory Point, please see your ADPAC."
- HANG 2
- DO RDL^RMPR29LU
- GOTO EXIT
- +1 SET RMPRGIP=$PIECE(^RMPR(669.9,RMPRSITE,0),U,3)
- SET RMFORM=15
- IF RMPRGIP
- SET PRCPPRIV=1
- DO INV^RMPR29LS
- if $DATA(RMEXIT)&($GET(REDIT))
- GOTO LAB
- if $DATA(RMEXIT)
- QUIT
- +2 if $DATA(RDEL)
- GOTO ITEM
- +3 ;
- VEN KILL DIC("S")
- +1 ;S X=" ",DIC=440,DIC(0)="ZM" D ^DIC S:+Y>0 DIC("B")=$P(^PRC(440,+Y,0),U,1)
- VEN0 IF $GET(RMLOC)
- IF $DATA(RMVEN)
- SET DIC("B")=RMVEN
- +1 SET DIC(0)="AEQM"
- SET DIC=440
- SET DIC("A")="VENDOR: "
- if $GET(REDIT)&($DATA(RMVENS))
- SET DIC("B")=RMVENS
- DO ^DIC
- +2 IF $DATA(DUOUT)!$DATA(DTOUT)
- if $GET(REDIT)
- GOTO LAB
- DO RDL^RMPR29LU
- GOTO EXIT
- +3 IF +Y'>0
- WRITE !!,?5,$CHAR(7),"This is a required response. Enter '^' to exit",!
- GOTO VEN
- +4 SET (RMVEN,RMVENS)=+Y
- KILL DIC,Y,X
- COS ;UNIT COST
- +1 IF (RMSO["C")&($GET(RMPRGIP))
- SET RMCOS=$PIECE($GET(^PRCP(445,PRCP("I"),1,PRCP("ITEM"),0)),U,15)
- +2 IF $GET(RMLOC)
- SET RMCOS=$PIECE($GET(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0)),U,10)
- +3 SET DIR(0)="667.3,3"
- SET DIR("A")="UNIT COST"
- +4 if $DATA(RMCOS)&($GET(RMCOS))
- SET DIR("B")=RMCOS
- +5 DO ^DIR
- KILL DIR
- +6 IF $DATA(DUOUT)!$DATA(DTOUT)
- if $GET(REDIT)
- GOTO LAB
- DO RDL^RMPR29LU
- GOTO EXIT
- +7 IF (RMSO["C")&(X<.001)
- WRITE !,"You must enter a UNIT COST....",!
- GOTO COS
- +8 SET RMCO=Y
- KILL DIR
- QTY SET DIR(0)="664.16,2"
- SET RMQTYS=$PIECE(RM0,U,2)
- if $DATA(RMQTYS)
- SET DIR("B")=RMQTYS
- DO ^DIR
- +1 IF $DATA(DUOUT)!$DATA(DTOUT)
- if $GET(REDIT)
- GOTO LAB
- DO RDL^RMPR29LU
- GOTO EXIT
- +2 IF X<1
- WRITE !,"You must enter a quantity....",!
- GOTO QTY
- +3 SET (RMQTY,RMQTYS)=Y
- KILL DIR
- +4 ;
- +5 KILL DIR
- SET DIR(0)="664.16,12"
- SET RMSERS=$PIECE(RM0,U,12)
- if $DATA(RMSERS)
- SET DIR("B")=RMSERS
- DO ^DIR
- +6 IF $DATA(DUOUT)!$DATA(DTOUT)
- if $GET(REDIT)
- GOTO LAB
- DO RDL^RMPR29LU
- GOTO EXIT
- +7 SET (RMSER,RMSERS)=Y
- KILL DIR
- +8 SET DIE(0)="AEQM"
- SET DR=4
- +9 SET DR(1,664.129)="4;"
- +10 SET DR(2,664.1294)=".01"
- +11 SET ^RMPR(664.1,RMPRDA,8,0)="^664.129DA"
- +12 SET ^RMPR(664.1,RMPRDA,8,1,1,0)="^664.1294^"
- +13 SET DA(1)=RMPRDA
- SET DIE="^RMPR(664.1,"_RMPRDA_",8,"
- +14 SET DA=1
- DO ^DIE
- KILL DIE,DR,DA
- +15 SET DA(1)=RMPRDA
- SET DA=RMIDA
- SET DIE="^RMPR(664.1,"_RMPRDA_",2,"
- +16 SET DR="2///^S X=$G(RMQTY);4///^S X=$G(RMCO);12///^S X=$G(RMSER);8///^S X=$G(RMTYP);9///^S X=$G(RMCAT);10///^S X=$G(RMSPE);16///^S X=$G(RMIT);14///^S X=$G(RMSO)"
- +17 DO ^DIE
- IF $DATA(DTOUT)!$DATA(DUOUT)
- if $GET(REDIT)
- GOTO LAB
- GOTO EXIT
- +18 SET RM0=$GET(^RMPR(664.1,RMPRDA,2,DA,0))
- SET RMQTY=$PIECE(RM0,U,2)
- SET RMCO=$PIECE(RM0,U,4)
- +19 IF RMQTY
- SET RMTOCO=RMQTY*RMCO
- SET DR="11///^S X=$G(RMTOCO);13///^S X=$G(RMHCPC)"
- DO ^DIE
- +20 if $GET(RMGIP)
- SET $PIECE(^RMPR(664.1,RMPRDA,2,DA,0),U,13)=RMGIP
- +21 SET $PIECE(^RMPR(664.1,RMPRDA,2,DA,3),U,4)=$GET(RMLOC)
- +22 SET $PIECE(^RMPR(664.1,RMPRDA,2,DA,3),U,2)=$GET(RMVEN)
- +23 GOTO ITEM
- LAB ;ASK TO POST REQUEST
- +1 IF $GET(REDIT)
- IF $DATA(RMIDA)
- DO SET^RMPR29LS
- +2 SET DIR(0)="Y"
- SET DIR("A")="Would you like to review this request"
- +3 SET DIR("B")="YES"
- DO ^DIR
- IF $DATA(DTOUT)!($DATA(DUOUT))
- DO CHK^RMPR29LU
- if $GET(RMEXIT)
- DO RDL^RMPR29LU
- GOTO EXIT
- +4 IF Y=1
- SET IOP="HOME"
- DO PRT^RMPR29R
- +5 DO CHK^RMPR29LU
- KILL RMNEW
- if $GET(RMEDIT)
- GOTO TYPE
- if $GET(RMEXIT)
- DO RDL^RMPR29LU
- if $GET(RMEXIT)
- GOTO EXIT
- +6 KILL DIR
- SET DIR(0)="Y"
- SET DIR("A")="Would you like to post this request"
- +7 SET DIR("B")="YES"
- DO ^DIR
- if $DATA(DTOUT)!($DATA(DUOUT))
- GOTO EXIT
- +8 IF +Y=0
- WRITE !!,?5,$CHAR(7),"Request not posted!!"
- DO RDL^RMPR29LU
- GOTO EXIT
- +9 SET RMPRWO=$PIECE(^RMPR(664.1,RMPRDA,0),U,13)
- if RMPRWO'=""
- GOTO PRINT
- SET SCR=$PIECE(^(0),U,11)
- +10 DO CR^RMPR29U(SCR)
- IF '$DATA(RMPRWO)
- WRITE !!,?5,$CHAR(7),"Request not posted!!"
- DO RDL^RMPR29LU
- GOTO EXIT
- PRINT DO SG^RMPR29LS
- +1 SET DIK="^RMPR(664.1,"
- SET DA=RMPRDA
- DO IX1^DIK
- KILL DIK,DA
- +2 WRITE !!
- SET DIR(0)="Y"
- SET DIR("A")="Would you like to print this 2529-3 request"
- +3 SET DIR("B")="YES"
- DO ^DIR
- if $DATA(DTOUT)!($DATA(DUOUT))
- GOTO EXIT
- IF Y=1
- DO PRT^RMPR29R
- +4 ;close a Lab Issue from Stock.
- +5 DO STA^RMPR29LC
- +6 ;suspense record inquiry
- +7 DO LINK^RMPRS
- +8 GOTO CREATE
- HELP ;
- +1 WRITE !,"** You can only select HCPCS that have a LAB pre-determined time.",!,"** If the HCPCS you are selecting are not in the list, please send an E-mail"
- +2 WRITE !,"** message to G.PROS-CODE@DOMAIN.EXT to be added in the list..."
- +3 QUIT
- +4 ;
- EXIT ;common exit
- +1 if +$GET(RMPRDA)
- LOCK -^RMPR(664.1,+RMPRDA,0)
- +2 ;I '$D(RMPR25)&('$D(RMPREDIT)) W !! S DIR(0)="Y",DIR("A")="Would you like to Process another 2529-3 Request",DIR("B")="NO" D ^DIR G:+Y=1 CREATE
- +3 NEW RMPR,RMPRSITE
- DO KILL^XUSCLEAN
- +4 QUIT
