Routine: RMPFDT10

RMPFDT10 ;DDC/KAW-LINE ITEM EXTENDED INFORMATION [ 06/16/95   3:06 PM ]

 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995

 ;; input: RMPFX

 ;;output: None

 S DFN=$P(^RMPF(791810,RMPFX,0),U,4) G END:'DFN D PAT^RMPFUTL K RMPFY

 D SEL G END:$D(RMPFOUT),END:'$D(RMPFY)

SHOW D HEAD,SET,DISP

 I IOST?1"C-".E D CONT G RMPFDT10:RMPFCT>1

 I IOST?1"P-".E W @IOF

 D:$D(IO("S")) ^%ZISC

END K DFN,RMPFNAM,RMPFSSN,RMPFDOB,RMPFDOD,X,Y,I,RMPFOUT,RMPFQUT,%XX,%YY

 K RMPFMD,RMPFO,RMPFTYP,RMPFHAT,ZTSK,XX,CX,RMPFY,CT,RR,RMPFCT

SET ;; input: RMPFX,RMPFY

 ;;output: None

 S SX=$G(^RMPF(791810,RMPFX,101,RMPFY,90))

 S AU=$P(SX,U,1) I AU,$D(^VA(200,AU,0)) S AU=$P(^(0),U,1)

 S AD=$P(SX,U,2) I AD S Y=AD D DD^%DT S AD=Y

 S AR=$P(SX,U,3),AM=$P(SX,U,4)

 S CR=$P(SX,U,5),DR=$P(SX,U,6) I DR S Y=DR D DD^%DT S DR=Y

 S UC=$P(SX,U,13) I UC,$D(^VA(200,UC,0)) S UC=$P(^(0),U,1)

 S SD=$P(SX,U,7) I SD S Y=SD D DD^%DT S SD=Y

 S CU=$P(SX,U,8) I CU,$D(^VA(200,CU,0)) S CU=$P(^(0),U,1)

 S CD=$P(SX,U,9) I CD S Y=CD D DD^%DT S CD=Y

 S RC=$P(SX,U,10) I RC,$D(^VA(200,RC,0)) S RC=$P(^(0),U,1)

 S RD=$P(SX,U,11) I RD S Y=RD D DD^%DT S RD=Y

 S IU=$P(SX,U,12) I IU,$D(^VA(200,IU,0)) S IU=$P(^(0),U,1)

 S OD=$P(SX,U,14) I OD,$D(^RMPF(791810.6,OD,0)) S OD=$P(^(0),U,1)

 I OD="OTHER",$P(SX,U,15)'="" S OD=$P(SX,U,15)

 S SX=$G(^RMPF(791810,RMPFX,101,RMPFY,2)),RR=$P(SX,U,7)

 K SX Q

DISP ;; input: AU,AD,AR,AM,CR,DR,SD,CU,CD,RC,RD,IU,UC,OD

 ;;output: None

 S XX=$Y G DI1:AU=""

 W !!,"User Making Last Adjustment: ",AU

 W !?4,"Date of Last Adjustment: ",AD

 W !?6,"Reason for Adjustment: ",AR

 W !?9,"Adjustment Message: ",AM

DI1 G DI2:UC=""&(CR="") W !!?16,"Canceled By: ",UC

 W:CR'="" !?14,"Cancel Reason: ",CR

DI2 W:DR'="" !?4,"Date Returned to Vendor: ",DR

 W:SD'="" !?18,"Ship Date: ",SD

 G DI3:CU=""

 W !!?15,"Certified By: ",CU

 W !?9,"Certification Date: ",CD

 W !?12,"Re-certified By: ",RC

 W !?6,"Re-certification Date: ",RD

DI3 W:IU'="" !?18,"Issued By: ",IU

 W:OD'="" !?11,"Reason for Delay: ",OD

 W:RR'="" !?4,"Reason for Registration: ",RR

 I $Y=XX W !!?9,"*** NO ADDITIONAL INFORMATION AVAILABLE FOR THIS LINE ITEM ***"

 K AU,AD,AR,AM,CR,DR,SD,CU,CD,IU,RD,RC,UC,XX,OD Q

SEL D ARRAY^RMPFDT2 S (RMPFCT,X)=0 F  S X=$O(RMPFO(X)) Q:'X  S RMPFY=X,RMPFCT=RMPFCT+1

 Q:RMPFCT=1

 S RMPFTYP=$P(^RMPF(791810,RMPFX,0),U,2),RMPFHAT=""

 I RMPFTYP,$D(^RMPF(791810.1,RMPFTYP,0)) S RMPFHAT=$P(^(0),U,2)

 W @IOF,!?33,"ITEMS ORDERED" D @("HEADP"_"^RMPFDT1")

 D ^RMPFDT2

S1 F  Q:$Y>21  W !

 W !,"Select number of a line item or <RETURN> to continue: " D READ

 Q:$D(RMPFOUT)

S2 I $D(RMPFQUT) W !!,"Select a number from the left of the display to choose a line item or",!,"<RETURN> to exit from the display." G S1

 Q:Y=""  I '$D(RMPFMD(Y)) S RMPFQUT="" G S2

 S RMPFY=RMPFMD(Y) Q

HEAD W:'$D(ZTSK) @IOF W !?22,"ROES LINE ITEM EXTENDED INFORMATION"

 I $D(RMPFNAM) W !,"Patient: ",$E(RMPFNAM,1,25),?35,"SSN: ",RMPFSSN,?68,RMPFDAT

 W ! F I=1:1:80 W "-"

 W ! Q

CONT F I=1:1 Q:$Y>20  W !

 W !,"Type <RETURN> to continue, <P>rint or <^> to exit: " D READ

 Q:$D(RMPFOUT)  G CONT:$D(RMPFQUT)

 D QUE:Y="P"

QUE W ! S %ZIS="NPQ" D ^%ZIS G END:POP

 I IO=IO(0),'$D(IO("S")) D SHOW^RMPFDT10 G QUEE

 I $D(IO("S")) S %ZIS="",IOP=ION D ^%ZIS G SHOW^RMPFDT10

 S ZTRTN="SHOW^RMPFDT10",ZTSAVE("RMPF*")="",ZTSAVE("DFN")=""

 S ZTIO=ION D ^%ZTLOAD

 D HOME^%ZIS S RMPFOUT=""

 W:$D(ZTSK) !!,"*** Request Queued ***" H 1

QUEE K %T,%ZIS,POP,ZTRTN,ZTSAVE,ZTIO,ZTSK Q

READ K RMPFOUT,RMPFQUT

 R Y:DTIME I '$T W $C(7) R Y:5 G READ:Y="." S:'$T Y=U

 I Y?1"^".E S (RMPFOUT,Y)="" Q

 S:Y?1"?".E (RMPFQUT,Y)=""

 K ZTSK Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFDT10   3621     printed  Apr 23, 2025@18:50:23                                                                                                                                                                                                    Page 2

RMPFDT10  ;DDC/KAW-LINE ITEM EXTENDED INFORMATION [ 06/16/95   3:06 PM ]

 +1       ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995

 +2       ;; input: RMPFX

 +3       ;;output: None

 +4        SET DFN=$PIECE(^RMPF(791810,RMPFX,0),U,4)

           if 'DFN

               GOTO END

           DO PAT^RMPFUTL

           KILL RMPFY

 +5        DO SEL

           if $DATA(RMPFOUT)

               GOTO END

           if '$DATA(RMPFY)

               GOTO END

SHOW       DO HEAD

           DO SET

           DO DISP

 +1        IF IOST?1"C-".E

               DO CONT

               if RMPFCT>1

                   GOTO RMPFDT10

 +2        IF IOST?1"P-".E

               WRITE @IOF

 +3        if $DATA(IO("S"))

               DO ^%ZISC

END        KILL DFN,RMPFNAM,RMPFSSN,RMPFDOB,RMPFDOD,X,Y,I,RMPFOUT,RMPFQUT,%XX,%YY

 +1        KILL RMPFMD,RMPFO,RMPFTYP,RMPFHAT,ZTSK,XX,CX,RMPFY,CT,RR,RMPFCT

 +2        QUIT

SET       ;; input: RMPFX,RMPFY

 +1       ;;output: None

 +2        SET SX=$GET(^RMPF(791810,RMPFX,101,RMPFY,90))

 +3        SET AU=$PIECE(SX,U,1)

           IF AU

               IF $DATA(^VA(200,AU,0))

                   SET AU=$PIECE(^(0),U,1)

 +4        SET AD=$PIECE(SX,U,2)

           IF AD

               SET Y=AD

               DO DD^%DT

               SET AD=Y

 +5        SET AR=$PIECE(SX,U,3)

           SET AM=$PIECE(SX,U,4)

 +6        SET CR=$PIECE(SX,U,5)

           SET DR=$PIECE(SX,U,6)

           IF DR

               SET Y=DR

               DO DD^%DT

               SET DR=Y

 +7        SET UC=$PIECE(SX,U,13)

           IF UC

               IF $DATA(^VA(200,UC,0))

                   SET UC=$PIECE(^(0),U,1)

 +8        SET SD=$PIECE(SX,U,7)

           IF SD

               SET Y=SD

               DO DD^%DT

               SET SD=Y

 +9        SET CU=$PIECE(SX,U,8)

           IF CU

               IF $DATA(^VA(200,CU,0))

                   SET CU=$PIECE(^(0),U,1)

 +10       SET CD=$PIECE(SX,U,9)

           IF CD

               SET Y=CD

               DO DD^%DT

               SET CD=Y

 +11       SET RC=$PIECE(SX,U,10)

           IF RC

               IF $DATA(^VA(200,RC,0))

                   SET RC=$PIECE(^(0),U,1)

 +12       SET RD=$PIECE(SX,U,11)

           IF RD

               SET Y=RD

               DO DD^%DT

               SET RD=Y

 +13       SET IU=$PIECE(SX,U,12)

           IF IU

               IF $DATA(^VA(200,IU,0))

                   SET IU=$PIECE(^(0),U,1)

 +14       SET OD=$PIECE(SX,U,14)

           IF OD

               IF $DATA(^RMPF(791810.6,OD,0))

                   SET OD=$PIECE(^(0),U,1)

 +15       IF OD="OTHER"

               IF $PIECE(SX,U,15)'=""

                   SET OD=$PIECE(SX,U,15)

 +16       SET SX=$GET(^RMPF(791810,RMPFX,101,RMPFY,2))

           SET RR=$PIECE(SX,U,7)

 +17       KILL SX

           QUIT

DISP      ;; input: AU,AD,AR,AM,CR,DR,SD,CU,CD,RC,RD,IU,UC,OD

 +1       ;;output: None

 +2        SET XX=$Y

           if AU=""

               GOTO DI1

 +3        WRITE !!,"User Making Last Adjustment: ",AU

 +4        WRITE !?4,"Date of Last Adjustment: ",AD

 +5        WRITE !?6,"Reason for Adjustment: ",AR

 +6        WRITE !?9,"Adjustment Message: ",AM

DI1        if UC=""&(CR="")

               GOTO DI2

           WRITE !!?16,"Canceled By: ",UC

 +1        if CR'=""

               WRITE !?14,"Cancel Reason: ",CR

DI2        if DR'=""

               WRITE !?4,"Date Returned to Vendor: ",DR

 +1        if SD'=""

               WRITE !?18,"Ship Date: ",SD

 +2        if CU=""

               GOTO DI3

 +3        WRITE !!?15,"Certified By: ",CU

 +4        WRITE !?9,"Certification Date: ",CD

 +5        WRITE !?12,"Re-certified By: ",RC

 +6        WRITE !?6,"Re-certification Date: ",RD

DI3        if IU'=""

               WRITE !?18,"Issued By: ",IU

 +1        if OD'=""

               WRITE !?11,"Reason for Delay: ",OD

 +2        if RR'=""

               WRITE !?4,"Reason for Registration: ",RR

 +3        IF $Y=XX

               WRITE !!?9,"*** NO ADDITIONAL INFORMATION AVAILABLE FOR THIS LINE ITEM ***"

 +4        KILL AU,AD,AR,AM,CR,DR,SD,CU,CD,IU,RD,RC,UC,XX,OD

           QUIT

SEL        DO ARRAY^RMPFDT2

           SET (RMPFCT,X)=0

FOR

               SET X=$ORDER(RMPFO(X))

               if 'X

                   QUIT

               SET RMPFY=X

               SET RMPFCT=RMPFCT+1

 +1        if RMPFCT=1

               QUIT

 +2        SET RMPFTYP=$PIECE(^RMPF(791810,RMPFX,0),U,2)

           SET RMPFHAT=""

 +3        IF RMPFTYP

               IF $DATA(^RMPF(791810.1,RMPFTYP,0))

                   SET RMPFHAT=$PIECE(^(0),U,2)

 +4        WRITE @IOF,!?33,"ITEMS ORDERED"

           DO @("HEADP"_"^RMPFDT1")

 +5        DO ^RMPFDT2

S1         FOR

               if $Y>21

                   QUIT

               WRITE !

 +1        WRITE !,"Select number of a line item or <RETURN> to continue: "

           DO READ

 +2        if $DATA(RMPFOUT)

               QUIT

S2         IF $DATA(RMPFQUT)

               WRITE !!,"Select a number from the left of the display to choose a line item or",!,"<RETURN> to exit from the display."

               GOTO S1

 +1        if Y=""

               QUIT

           IF '$DATA(RMPFMD(Y))

               SET RMPFQUT=""

               GOTO S2

 +2        SET RMPFY=RMPFMD(Y)

           QUIT

 +3        QUIT

HEAD       if '$DATA(ZTSK)

               WRITE @IOF

           WRITE !?22,"ROES LINE ITEM EXTENDED INFORMATION"

 +1        IF $DATA(RMPFNAM)

               WRITE !,"Patient: ",$EXTRACT(RMPFNAM,1,25),?35,"SSN: ",RMPFSSN,?68,RMPFDAT

 +2        WRITE !

           FOR I=1:1:80

               WRITE "-"

 +3        WRITE !

           QUIT

CONT       FOR I=1:1

               if $Y>20

                   QUIT

               WRITE !

 +1        WRITE !,"Type <RETURN> to continue, <P>rint or <^> to exit: "

           DO READ

 +2        if $DATA(RMPFOUT)

               QUIT

           if $DATA(RMPFQUT)

               GOTO CONT

 +3        if Y="P"

               DO QUE

 +4        QUIT

QUE        WRITE !

           SET %ZIS="NPQ"

           DO ^%ZIS

           if POP

               GOTO END

 +1        IF IO=IO(0)

               IF '$DATA(IO("S"))

                   DO SHOW^RMPFDT10

                   GOTO QUEE

 +2        IF $DATA(IO("S"))

               SET %ZIS=""

               SET IOP=ION

               DO ^%ZIS

               GOTO SHOW^RMPFDT10

 +3        SET ZTRTN="SHOW^RMPFDT10"

           SET ZTSAVE("RMPF*")=""

           SET ZTSAVE("DFN")=""

 +4        SET ZTIO=ION

           DO ^%ZTLOAD

 +5        DO HOME^%ZIS

           SET RMPFOUT=""

 +6        if $DATA(ZTSK)

               WRITE !!,"*** Request Queued ***"

           HANG 1

QUEE       KILL %T,%ZIS,POP,ZTRTN,ZTSAVE,ZTIO,ZTSK

           QUIT

READ       KILL RMPFOUT,RMPFQUT

 +1        READ Y:DTIME

           IF '$TEST

               WRITE $CHAR(7)

               READ Y:5

               if Y="."

                   GOTO READ

               if '$TEST

                   SET Y=U

 +2        IF Y?1"^".E

               SET (RMPFOUT,Y)=""

               QUIT

 +3        if Y?1"?".E

               SET (RMPFQUT,Y)=""

 +4        QUIT

 +5        KILL ZTSK

           QUIT

RMPFDT10.m