Routine: RMPRPIYJ

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

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")

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIYJ   4208     printed  Mar 13, 2025@21:42                                                                                                                                                                                                       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

RMPRPIYJ.m