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
Q
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
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"
Q
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)=""
Q
K ZTSK Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFDT10 3621 printed Apr 09, 2024@21:38:42 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
