- RMPFDT4 ;DDC/KAW-DISPLAY ORDER MESSAGES [ 06/16/95 3:06 PM ]
- ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
- ;;input : RMPFX
- ;;output: None
- Q:'$D(RMPFX) I $D(DFN),DFN D PAT^RMPFUTL
- S Y=$P(^RMPF(791810,RMPFX,0),U,1),%DT="T" D DD^%DT S TT=Y
- S TP=$P(^RMPF(791810,RMPFX,0),U,2)
- I TP,$D(^RMPF(791810.1,TP,0)) S TP=$P(^(0),U,1)
- S (CM,CX)=0 D HEAD
- A1 S CM=$O(^RMPF(791810,RMPFX,201,CM)) G EXIT:'CM,A1:'$D(^(CM,0)) S S0=^(0),RMPFMD=""
- S Y=$P(S0,U,5) I Y D DD^%DT S RMPFMD=Y
- I RMPFMD="" S Y=$P(^RMPF(791810,RMPFX,201,CM,0),".",1) D DD^%DT S RMPFMD=Y
- S CE=0
- A2 S CE=$O(^RMPF(791810,RMPFX,201,CM,101,CE)) G A1:'CE G A2:'$D(^(CE,0)) S S1=^(0),MG=$P(S1,U,1),PR=$P(S1,U,2),Y=$P(S1,U,10) D DD^%DT S SD=Y
- S EX=$P(S1,U,3),ST=$P(S1,U,4),LR=$P(S1,U,7)
- I IOST?1"C-".E,$Y>20 D CONT G END:$D(ZTSK) D HEAD
- I IOST?1"P-".E,$Y>58 W @IOF D HEAD
- I LR,$D(^VA(200,LR,0)) S LR=$E($P(^(0),U,2),1,4)
- W !!,RMPFMD,?15,$E(PR,1,17),?35,EX
- I ST W ?52,$S($D(^RMPF(791810.2,ST,0)):$P(^(0),U,4),1:"")
- W ?61,SD,?76,LR
- W !?3,"Message: ",$E(MG,1,66) S CX=CX+1
- G A2
- EXIT W:CX=0 !!,"*** NO MESSAGES TO DISPLAY ***"
- I CX S XX=0 F I=1:1 S XX=$O(^RMPF(791810,RMPFX,201,XX)) Q:'XX S YY=0 F J=1:1 S YY=$O(^RMPF(791810,RMPFX,201,XX,101,YY)) Q:'YY D
- .S DIE="^RMPF(791810,"_RMPFX_",201,"_XX_",101,"
- .S DA(2)=RMPFX,DA(1)=XX,DA=YY
- .S DR=".06////1;.07////"_DUZ D ^DIE
- .K DR,DA,DIE,D,D0,DQ Q
- I IOST?1"C-".E D CONT G END:$D(RMPFOUT),END:'$D(Y),END:Y="",RMPFDT4
- I IOST?1"P-".E W @IOF
- D:$D(IO("S")) ^%ZISC
- END K I,CM,CX,S0,Y,X,%,%DT,%Y,RMPFMD,CE,S1,MG,PR,EX,ST,SD,RMPFNAM,RMPFDOB
- K RMPFSSN,TT,TP,LR,DI,DIC,XX,YY,J,ZTSK,%XX,%YY Q
- HEAD W:IOST?1"C-".E @IOF W !?32,"MESSAGE UPDATES"
- W !,"Station: ",RMPFSTAP,?68,RMPFDAT
- I $D(RMPFNAM) W !,"Patient: ",$E(RMPFNAM,1,25),?40,"SSN: ",RMPFSSN,?62,"DOB: ",RMPFDOB
- W !?2,"Order: ",TP,!?3,"Date: ",TT
- W ! F I=1:1:80 W "-"
- W !?4,"DDC",?76,"Last"
- W !,"Process Date",?20,"Sender",?37,"Telephone",?52,"Status",?62,"Ship Date",?76,"Read"
- W !,"------------",?15,"-----------------",?35,"--------------",?52,"------",?61,"------------",?76,"----"
- Q
- CONT F I=1:1 Q:$Y>20 W !
- W !,"Type <P>rint or <RETURN> to continue: " D READ
- Q:$D(RMPFOUT)
- CONT1 I $D(RMPFQUT) K RMPFQUT D MSG^RMPFDD G CONT1:$D(RMPFQUT) Q
- Q:Y="" S Y=$E(Y,1) I "Pp"'[Y S RMPFQUT="" G CONT1
- QUE W ! S %ZIS="QNP" D ^%ZIS G END:POP
- I IO=IO(0),'$D(IO("S")) D QUEE S Y=1 Q
- I $D(IO("S")) S %ZIS="",IOP=ION D ^%ZIS G ^RMPFDT4
- S ZTRTN="^RMPFDT4",ZTSAVE("RMPF*")="",ZTSAVE("DFN")="",ZTIO=ION
- D ^%ZTLOAD
- D HOME^%ZIS W:$D(ZTSK) !!,"*** Request Queued ***" H 2
- QUEE K %T,%ZIS,POP,ZTRTN,ZTSAVE,ZTIO 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFDT4 2777 printed Apr 23, 2025@18:50:26 Page 2
- RMPFDT4 ;DDC/KAW-DISPLAY ORDER MESSAGES [ 06/16/95 3:06 PM ]
- +1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
- +2 ;;input : RMPFX
- +3 ;;output: None
- +4 if '$DATA(RMPFX)
- QUIT
- IF $DATA(DFN)
- IF DFN
- DO PAT^RMPFUTL
- +5 SET Y=$PIECE(^RMPF(791810,RMPFX,0),U,1)
- SET %DT="T"
- DO DD^%DT
- SET TT=Y
- +6 SET TP=$PIECE(^RMPF(791810,RMPFX,0),U,2)
- +7 IF TP
- IF $DATA(^RMPF(791810.1,TP,0))
- SET TP=$PIECE(^(0),U,1)
- +8 SET (CM,CX)=0
- DO HEAD
- A1 SET CM=$ORDER(^RMPF(791810,RMPFX,201,CM))
- if 'CM
- GOTO EXIT
- if '$DATA(^(CM,0))
- GOTO A1
- SET S0=^(0)
- SET RMPFMD=""
- +1 SET Y=$PIECE(S0,U,5)
- IF Y
- DO DD^%DT
- SET RMPFMD=Y
- +2 IF RMPFMD=""
- SET Y=$PIECE(^RMPF(791810,RMPFX,201,CM,0),".",1)
- DO DD^%DT
- SET RMPFMD=Y
- +3 SET CE=0
- A2 SET CE=$ORDER(^RMPF(791810,RMPFX,201,CM,101,CE))
- if 'CE
- GOTO A1
- if '$DATA(^(CE,0))
- GOTO A2
- SET S1=^(0)
- SET MG=$PIECE(S1,U,1)
- SET PR=$PIECE(S1,U,2)
- SET Y=$PIECE(S1,U,10)
- DO DD^%DT
- SET SD=Y
- +1 SET EX=$PIECE(S1,U,3)
- SET ST=$PIECE(S1,U,4)
- SET LR=$PIECE(S1,U,7)
- +2 IF IOST?1"C-".E
- IF $Y>20
- DO CONT
- if $DATA(ZTSK)
- GOTO END
- DO HEAD
- +3 IF IOST?1"P-".E
- IF $Y>58
- WRITE @IOF
- DO HEAD
- +4 IF LR
- IF $DATA(^VA(200,LR,0))
- SET LR=$EXTRACT($PIECE(^(0),U,2),1,4)
- +5 WRITE !!,RMPFMD,?15,$EXTRACT(PR,1,17),?35,EX
- +6 IF ST
- WRITE ?52,$SELECT($DATA(^RMPF(791810.2,ST,0)):$PIECE(^(0),U,4),1:"")
- +7 WRITE ?61,SD,?76,LR
- +8 WRITE !?3,"Message: ",$EXTRACT(MG,1,66)
- SET CX=CX+1
- +9 GOTO A2
- EXIT if CX=0
- WRITE !!,"*** NO MESSAGES TO DISPLAY ***"
- +1 IF CX
- SET XX=0
- FOR I=1:1
- SET XX=$ORDER(^RMPF(791810,RMPFX,201,XX))
- if 'XX
- QUIT
- SET YY=0
- FOR J=1:1
- SET YY=$ORDER(^RMPF(791810,RMPFX,201,XX,101,YY))
- if 'YY
- QUIT
- Begin DoDot:1
- +2 SET DIE="^RMPF(791810,"_RMPFX_",201,"_XX_",101,"
- +3 SET DA(2)=RMPFX
- SET DA(1)=XX
- SET DA=YY
- +4 SET DR=".06////1;.07////"_DUZ
- DO ^DIE
- +5 KILL DR,DA,DIE,D,D0,DQ
- QUIT
- End DoDot:1
- +6 IF IOST?1"C-".E
- DO CONT
- if $DATA(RMPFOUT)
- GOTO END
- if '$DATA(Y)
- GOTO END
- if Y=""
- GOTO END
- GOTO RMPFDT4
- +7 IF IOST?1"P-".E
- WRITE @IOF
- +8 if $DATA(IO("S"))
- DO ^%ZISC
- END KILL I,CM,CX,S0,Y,X,%,%DT,%Y,RMPFMD,CE,S1,MG,PR,EX,ST,SD,RMPFNAM,RMPFDOB
- +1 KILL RMPFSSN,TT,TP,LR,DI,DIC,XX,YY,J,ZTSK,%XX,%YY
- QUIT
- HEAD if IOST?1"C-".E
- WRITE @IOF
- WRITE !?32,"MESSAGE UPDATES"
- +1 WRITE !,"Station: ",RMPFSTAP,?68,RMPFDAT
- +2 IF $DATA(RMPFNAM)
- WRITE !,"Patient: ",$EXTRACT(RMPFNAM,1,25),?40,"SSN: ",RMPFSSN,?62,"DOB: ",RMPFDOB
- +3 WRITE !?2,"Order: ",TP,!?3,"Date: ",TT
- +4 WRITE !
- FOR I=1:1:80
- WRITE "-"
- +5 WRITE !?4,"DDC",?76,"Last"
- +6 WRITE !,"Process Date",?20,"Sender",?37,"Telephone",?52,"Status",?62,"Ship Date",?76,"Read"
- +7 WRITE !,"------------",?15,"-----------------",?35,"--------------",?52,"------",?61,"------------",?76,"----"
- +8 QUIT
- CONT FOR I=1:1
- if $Y>20
- QUIT
- WRITE !
- +1 WRITE !,"Type <P>rint or <RETURN> to continue: "
- DO READ
- +2 if $DATA(RMPFOUT)
- QUIT
- CONT1 IF $DATA(RMPFQUT)
- KILL RMPFQUT
- DO MSG^RMPFDD
- if $DATA(RMPFQUT)
- GOTO CONT1
- QUIT
- +1 if Y=""
- QUIT
- SET Y=$EXTRACT(Y,1)
- IF "Pp"'[Y
- SET RMPFQUT=""
- GOTO CONT1
- QUE WRITE !
- SET %ZIS="QNP"
- DO ^%ZIS
- if POP
- GOTO END
- +1 IF IO=IO(0)
- IF '$DATA(IO("S"))
- DO QUEE
- SET Y=1
- QUIT
- +2 IF $DATA(IO("S"))
- SET %ZIS=""
- SET IOP=ION
- DO ^%ZIS
- GOTO ^RMPFDT4
- +3 SET ZTRTN="^RMPFDT4"
- SET ZTSAVE("RMPF*")=""
- SET ZTSAVE("DFN")=""
- SET ZTIO=ION
- +4 DO ^%ZTLOAD
- +5 DO HOME^%ZIS
- if $DATA(ZTSK)
- WRITE !!,"*** Request Queued ***"
- HANG 2
- QUEE KILL %T,%ZIS,POP,ZTRTN,ZTSAVE,ZTIO
- 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
