RMPRPIYJ ;HINCIO/RVD-ISSUE FROM STOCK / CONT. ;9/18/02 07:39
;;3.0;PROSTHETICS;**61,128**;Feb 09, 1996
; RVD #61 - pip INVENTORY PHASE IIIa
;
;Per VHA Directive 10-93-142, this routine should not be modified.
QTY K DIR,Y S DIR(0)="660,5",DIR("B")=1 S:$P(R1(0),U,7) DIR("B")=$P(R1(0),U,7)
D ^DIR I $P(R1(0),U,7)'=""&$D(DUOUT) G LIST
I $D(DTOUT) X CK2 G ^RMPRPIYI
I $D(DIRUT) G ^RMPRPIYI
I $G(RMUBA),((RMUBA-Y)<0) D LOWBA^RMPRPIYI G 2^RMPRPIYI
I $G(RMITQTY),RMITQTY<Y W !,"Issue quantity exceeds on-hand (",RMITQTY,") for scanned item bar code!!",! G QTY
S $P(R1(0),U,7)=Y,$P(R1(0),U,16)=Y*RMPRUCST K DIR
;
DATE ;delivery date is set to today's date
S $P(R1(0),U,12)=DT,Y=DT D DD^%DT S $P(R3("D"),U,12)=Y
;
SERV ;date of service
S Y=DT D DD^%DT S DIR("B")=Y,DIR("A")="DATE OF SERVICE",DIR(0)="660,39"
I $G(REDIT) S DIR("B")=$P(R1("D"),U,8)
D ^DIR K DIR I $D(DTOUT) X CK2 G ^RMPRPIYI
I $D(DUOUT),$G(REDIT) G LIST
I (X="")!(X="@") W !,"This field is mandatory!!!",! G SERV
S $P(R1(1),U,8)=Y D DD^%DT S $P(R1("D"),U,8)=Y
;
LI S DIR(0)="660,9" S:$P(R1(0),U,11)'="" DIR("B")=$P(R1(0),U,11)
D ^DIR I $D(DTOUT) X CK1 Q
G:$D(DUOUT) LIST
I X["^" W !,"Jumping not allowed" G LI
I $P(R1(0),U,11)'=""&(X="@") S $P(R1(0),U,11)="" W $C(7),!?5,"Deleted..." H 1 G LOT
S $P(R1(0),U,11)=X
;
LOT ;
;
K DIR S DIR(0)="660,21" S:$P(R1(0),U,24)'="" DIR("B")=$P(R1(0),U,24)
D ^DIR I $D(DTOUT) X CK1 Q
G:$D(DUOUT) LIST
I X["^" W !,"Jumping not allowed" G LOT
I $P(R1(0),U,24)'=""&(X="@") S $P(R1(0),U,24)="" W $C(7),!?5,"Deleted..." H 1 G REMA
S $P(R1(0),U,24)=X
;
REMA ;
;
K DIR S DIR(0)="660,16" S:$P(R1(0),U,18)'="" DIR("B")=$P(R1(0),U,18)
D ^DIR I $D(DTOUT) X CK1 Q
G:$D(DUOUT) LIST
I X["^" W !,"Jumping not allowed" G REMA
I $P(R1(0),U,18)'=""&(X="@") S $P(R1(0),U,18)="" W $C(7),!?5,"Deleted..." H 1 G LIST
S $P(R1(0),U,18)=X
;
LIST ;ENTRY POINT FOR STOCK ISSUE ROUTINES TO DISPLAY TRANSACTION DATA
S RMDAHC=$P(R1(1),U,4)
D:$D(RMCPT) CHK^RMPRED5
D ^RMPRPIYK
K DIR,RQUIT
S DIR(0)="SBO^P:POST;E:EDIT;D:DELETE"
S DIR("A")="Would you like to POST/EDIT/DELETE this entry"
S DIR("B")="P"
S 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 G:Y="D" DEA
I Y="E" S REDIT=1 G 1^RMPRPIYI
I $D(DIRUT)!$D(DUOUT)!$D(DTOUT) G ^RMPRPIYI
;
DEA ;
K DIR
S DIR("A")="Are you sure you want to DELETE this entry"
S DIR("B")="N",DIR(0)="Y"
D ^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIRUT) X CK Q
I Y=1 W !!,$C(7),?50," Deleted..." H 2 K DIR G RES^RMPRPIYI
G LIST
;
POST ;
I RMPR699("AMIS GROUPER")'="" G GGC
S RMPRAMIS=0
S RMPR699("IEN")=RMPRSITE
S RMPRAMIS=$$AMGR^RMPRPIX2(.RMPR699)
I RMPRAMIS X CK Q
GGC ;
D SETARR(.RMPR60)
S RMPRERR=$$ISS^RMPRPIU6(.RMPR60,.RMPR11I,.RMPR5)
I RMPRERR=9 D LOWBA^RMPRPIYI G 2^RMPRPIYI
I RMPRERR W !,"*** ERROR in API RMPRPIU6, ERROR = ",RMPRERR," !!!" G EXIT
S ^TMP($J,"RMPRPCE",660,RMPR60("IEN"))=RMPR699("AMIS GROUPER")_"^"_$G(RMPRDFN)
;
W !,"Posted to 2319..." H 3
G RES^RMPRPIYI
;
EXIT ;EXIT FOR STOCK ISSUES
N RMPRSITE,RMPR D KILL^XUSCLEAN
Q
;
INV1 I $P(R1(0),U,14)="C" S $P(R1(0),U,16)=RMPRUCST*$P(R1(0),U,7)
G QTY
;
; Set up arrays for Stock Issue Transaction
SETARR(RMPR60) ;
K RMPR60
S RMPR60("ENTRY DATE")=$P(R1(0),U,1)
S RMPR60("PATIENT IEN")=$P(R1(0),U,2)
S RMPR60("ISSUE TYPE")=$P(R1(0),U,4)
S RMPR60("QUANTITY")=$P(R1(0),U,7)
S RMPR60("IFCAP ITEM")=$P(R1(0),U,6)
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("HCPCS")=$P(R1(1),U,4)
S RMPR60("CPT IEN")=$P(R1(0),U,22)
S RMPR60("CPT MOD")=$P(R1(1),U,6)
S RMPR60("PAT CAT")=$P(R1("AM"),U,3)
S RMPR60("SPEC CAT")=$P(R1("AM"),U,4)
S RMPR60("USER")=$P(R1(0),U,27)
S RMPR60("SITE IEN")=RMPRSITE
S RMPR60("GROUPER")=RMPR699("AMIS GROUPER")
S RMPR60("DATE&TIME")=R1("DATE&TIME")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIYJ 4208 printed Oct 16, 2024@18:37:45 Page 2
RMPRPIYJ ;HINCIO/RVD-ISSUE FROM STOCK / CONT. ;9/18/02 07:39
+1 ;;3.0;PROSTHETICS;**61,128**;Feb 09, 1996
+2 ; RVD #61 - pip INVENTORY PHASE IIIa
+3 ;
+4 ;Per VHA Directive 10-93-142, this routine should not be modified.
QTY KILL DIR,Y
SET DIR(0)="660,5"
SET DIR("B")=1
if $PIECE(R1(0),U,7)
SET DIR("B")=$PIECE(R1(0),U,7)
+1 DO ^DIR
IF $PIECE(R1(0),U,7)'=""&$DATA(DUOUT)
GOTO LIST
+2 IF $DATA(DTOUT)
XECUTE CK2
GOTO ^RMPRPIYI
+3 IF $DATA(DIRUT)
GOTO ^RMPRPIYI
+4 IF $GET(RMUBA)
IF ((RMUBA-Y)<0)
DO LOWBA^RMPRPIYI
GOTO 2^RMPRPIYI
+5 IF $GET(RMITQTY)
IF RMITQTY<Y
WRITE !,"Issue quantity exceeds on-hand (",RMITQTY,") for scanned item bar code!!",!
GOTO QTY
+6 SET $PIECE(R1(0),U,7)=Y
SET $PIECE(R1(0),U,16)=Y*RMPRUCST
KILL DIR
+7 ;
DATE ;delivery date is set to today's date
+1 SET $PIECE(R1(0),U,12)=DT
SET Y=DT
DO DD^%DT
SET $PIECE(R3("D"),U,12)=Y
+2 ;
SERV ;date of service
+1 SET Y=DT
DO DD^%DT
SET DIR("B")=Y
SET DIR("A")="DATE OF SERVICE"
SET DIR(0)="660,39"
+2 IF $GET(REDIT)
SET DIR("B")=$PIECE(R1("D"),U,8)
+3 DO ^DIR
KILL DIR
IF $DATA(DTOUT)
XECUTE CK2
GOTO ^RMPRPIYI
+4 IF $DATA(DUOUT)
IF $GET(REDIT)
GOTO LIST
+5 IF (X="")!(X="@")
WRITE !,"This field is mandatory!!!",!
GOTO SERV
+6 SET $PIECE(R1(1),U,8)=Y
DO DD^%DT
SET $PIECE(R1("D"),U,8)=Y
+7 ;
LI SET DIR(0)="660,9"
if $PIECE(R1(0),U,11)'=""
SET DIR("B")=$PIECE(R1(0),U,11)
+1 DO ^DIR
IF $DATA(DTOUT)
XECUTE CK1
QUIT
+2 if $DATA(DUOUT)
GOTO LIST
+3 IF X["^"
WRITE !,"Jumping not allowed"
GOTO LI
+4 IF $PIECE(R1(0),U,11)'=""&(X="@")
SET $PIECE(R1(0),U,11)=""
WRITE $CHAR(7),!?5,"Deleted..."
HANG 1
GOTO LOT
+5 SET $PIECE(R1(0),U,11)=X
+6 ;
LOT ;
+1 ;
+2 KILL DIR
SET DIR(0)="660,21"
if $PIECE(R1(0),U,24)'=""
SET DIR("B")=$PIECE(R1(0),U,24)
+3 DO ^DIR
IF $DATA(DTOUT)
XECUTE CK1
QUIT
+4 if $DATA(DUOUT)
GOTO LIST
+5 IF X["^"
WRITE !,"Jumping not allowed"
GOTO LOT
+6 IF $PIECE(R1(0),U,24)'=""&(X="@")
SET $PIECE(R1(0),U,24)=""
WRITE $CHAR(7),!?5,"Deleted..."
HANG 1
GOTO REMA
+7 SET $PIECE(R1(0),U,24)=X
+8 ;
REMA ;
+1 ;
+2 KILL DIR
SET DIR(0)="660,16"
if $PIECE(R1(0),U,18)'=""
SET DIR("B")=$PIECE(R1(0),U,18)
+3 DO ^DIR
IF $DATA(DTOUT)
XECUTE CK1
QUIT
+4 if $DATA(DUOUT)
GOTO LIST
+5 IF X["^"
WRITE !,"Jumping not allowed"
GOTO REMA
+6 IF $PIECE(R1(0),U,18)'=""&(X="@")
SET $PIECE(R1(0),U,18)=""
WRITE $CHAR(7),!?5,"Deleted..."
HANG 1
GOTO LIST
+7 SET $PIECE(R1(0),U,18)=X
+8 ;
LIST ;ENTRY POINT FOR STOCK ISSUE ROUTINES TO DISPLAY TRANSACTION DATA
+1 SET RMDAHC=$PIECE(R1(1),U,4)
+2 if $DATA(RMCPT)
DO CHK^RMPRED5
+3 DO ^RMPRPIYK
+4 KILL DIR,RQUIT
+5 SET DIR(0)="SBO^P:POST;E:EDIT;D:DELETE"
+6 SET DIR("A")="Would you like to POST/EDIT/DELETE this entry"
+7 SET DIR("B")="P"
+8 SET DIR("?")="Answer `P` to post the transaction, `E` to edit the transaction,'D' to delete the transaction"
+9 DO ^DIR
KILL DIR
if Y="P"
GOTO POST
if Y="D"
GOTO DEA
+10 IF Y="E"
SET REDIT=1
GOTO 1^RMPRPIYI
+11 IF $DATA(DIRUT)!$DATA(DUOUT)!$DATA(DTOUT)
GOTO ^RMPRPIYI
+12 ;
DEA ;
+1 KILL DIR
+2 SET DIR("A")="Are you sure you want to DELETE this entry"
+3 SET DIR("B")="N"
SET DIR(0)="Y"
+4 DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)
XECUTE CK
QUIT
+5 IF Y=1
WRITE !!,$CHAR(7),?50," Deleted..."
HANG 2
KILL DIR
GOTO RES^RMPRPIYI
+6 GOTO LIST
+7 ;
POST ;
+1 IF RMPR699("AMIS GROUPER")'=""
GOTO GGC
+2 SET RMPRAMIS=0
+3 SET RMPR699("IEN")=RMPRSITE
+4 SET RMPRAMIS=$$AMGR^RMPRPIX2(.RMPR699)
+5 IF RMPRAMIS
XECUTE CK
QUIT
GGC ;
+1 DO SETARR(.RMPR60)
+2 SET RMPRERR=$$ISS^RMPRPIU6(.RMPR60,.RMPR11I,.RMPR5)
+3 IF RMPRERR=9
DO LOWBA^RMPRPIYI
GOTO 2^RMPRPIYI
+4 IF RMPRERR
WRITE !,"*** ERROR in API RMPRPIU6, ERROR = ",RMPRERR," !!!"
GOTO EXIT
+5 SET ^TMP($JOB,"RMPRPCE",660,RMPR60("IEN"))=RMPR699("AMIS GROUPER")_"^"_$GET(RMPRDFN)
+6 ;
+7 WRITE !,"Posted to 2319..."
HANG 3
+8 GOTO RES^RMPRPIYI
+9 ;
EXIT ;EXIT FOR STOCK ISSUES
+1 NEW RMPRSITE,RMPR
DO KILL^XUSCLEAN
+2 QUIT
+3 ;
INV1 IF $PIECE(R1(0),U,14)="C"
SET $PIECE(R1(0),U,16)=RMPRUCST*$PIECE(R1(0),U,7)
+1 GOTO QTY
+2 ;
+3 ; Set up arrays for Stock Issue Transaction
SETARR(RMPR60) ;
+1 KILL RMPR60
+2 SET RMPR60("ENTRY DATE")=$PIECE(R1(0),U,1)
+3 SET RMPR60("PATIENT IEN")=$PIECE(R1(0),U,2)
+4 SET RMPR60("ISSUE TYPE")=$PIECE(R1(0),U,4)
+5 SET RMPR60("QUANTITY")=$PIECE(R1(0),U,7)
+6 SET RMPR60("IFCAP ITEM")=$PIECE(R1(0),U,6)
+7 SET RMPR60("UNIT")=$PIECE(R1(0),U,8)
+8 SET RMPR60("VENDOR IEN")=$PIECE(R1(0),U,9)
+9 SET RMPR60("SERIAL NUM")=$PIECE(R1(0),U,11)
+10 SET RMPR60("DELIV DATE")=$PIECE(R1(0),U,12)
+11 SET RMPR60("DATE OF SERVICE")=$PIECE(R1(1),U,8)
+12 SET RMPR60("SOURCE")=$PIECE(R1(0),U,14)
+13 SET RMPR60("COST")=$PIECE(R1(0),U,16)
+14 SET RMPR60("REMARKS")=$PIECE(R1(0),U,18)
+15 SET RMPR60("LOT NUM")=$PIECE(R1(0),U,24)
+16 SET RMPR60("HCPCS")=$PIECE(R1(1),U,4)
+17 SET RMPR60("CPT IEN")=$PIECE(R1(0),U,22)
+18 SET RMPR60("CPT MOD")=$PIECE(R1(1),U,6)
+19 SET RMPR60("PAT CAT")=$PIECE(R1("AM"),U,3)
+20 SET RMPR60("SPEC CAT")=$PIECE(R1("AM"),U,4)
+21 SET RMPR60("USER")=$PIECE(R1(0),U,27)
+22 SET RMPR60("SITE IEN")=RMPRSITE
+23 SET RMPR60("GROUPER")=RMPR699("AMIS GROUPER")
+24 SET RMPR60("DATE&TIME")=R1("DATE&TIME")
+25 QUIT
