RMPFDS1 ;DDC/KAW-LIST ORDERS BY PATIENT OR STATUS; [ 03/12/98 7:45 AM ]
;;2.0;REMOTE ORDER/ENTRY SYSTEM;**8,10,16**;MAY 30, 1995
;;Reference to ^VA(200) supported by DBIA #10060
;; input: RMPFTP,RMPFORD,DFN (if RMPFORD="P")
;;output: RMPFS,RMPFCX,RMPFO
I $D(DFN),DFN D PAT^RMPFUTL
D @("HEAD"_RMPFORD) S (RMPF,RMPFCX)=0
I RMPFORD="S" F I=1:1 S RMPF=$O(^RMPF(791810,"AD",RMPF)) Q:'RMPF G END:$D(RMPFOUT) S RMPFX=0 F J=1:1 S RMPFX=$O(^RMPF(791810,"AD",RMPF,RMPFX)) Q:'RMPFX D SUB G END:$D(RMPFOUT),END:'$D(RMPFX)
I RMPFORD="P" F I=1:1 S RMPF=$O(^RMPF(791810,"AE",DFN,RMPF)) Q:RMPF="" G END:$D(RMPFOUT) S RMPFX=0 F J=1:1 S RMPFX=$O(^RMPF(791810,"AE",DFN,RMPF,RMPFX)) Q:'RMPFX D SUB G END:$D(RMPFOUT),END:'$D(RMPFX)
G END:$D(RMPFOUT)
W:RMPFCX<1 !!,"NO EXISTING ORDERS"
W:RMPFCX !!,"Total Orders: ",RMPFCX
W:IOST?1"P-".E @IOF
D:$D(IO("S")) ^%ZISC
END K RMPFNAM,SSN,RMPFSSN,RMPFDOB,DOB,Y,RMPF,RMPFX,RMPFST,RMPFMGG,RMPFSD
K I,J,T,RMPFDOD,OO 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"^" S (RMPFOUT,Y)="" Q
S:Y?1"?".E (RMPFQUT,Y)=""
Q
SUB ;;input: RMPFX,RMPFTP,RMPFORD,RMPFCX,RMPFNAM,RMPFSSN,RMPFDOB,RMPFP (opt), RMPFOO (opt.)
;;output: RMPFCX,RMPFS
Q:RMPFX=""
Q:'$D(^RMPF(791810,RMPFX,0)) S SX=^(0)
S X=$P(SX,U,15) S:X="" X=1 S X=$P(^RMPF(791810.5,X,0),U,2) S:X="" X=1 Q:X'=RMPFMENU
Q:'$D(^RMPF(791810,RMPFX,"STA")) Q:$P(RMPFSTAP," - ",1)'=$P($P(^("STA"),U,1)," - ",1)
I $D(RMPFOO) D I OO,OO'=RMPFOO Q
.S OO=$P(SX,U,8),X=0 D ARRAY^RMPFDT2
.F S X=$O(RMPFO(X)) Q:'X I $D(^RMPF(791810,RMPFX,101,X,90)),$P(^(90),U,12) S OO=$P(^(90),U,12)
S Y=$P($P(SX,U,1),".",1),RMPFTDP=$E(Y,4,5)_"-"_$E(Y,6,7)_"-"_($E(Y,1,3)+1700)
S Y=$P($P(SX,U,6),".",1),RMPFSD=$E(Y,4,5)_"-"_$E(Y,6,7)_"-"_($E(Y,1,3)+1700)
S RMPFTYP="",X=$P(SX,U,2)
G SUBE:'X,SUBE:'$D(^RMPF(791810.1,X,0)) S SS=^(0)
S RMPFTYP=$S(RMPFTP'="S":$P(SS,U,8),1:$P(SS,U,1)),T=$P(SS,U,3)
I RMPFTP'="B" G SUBE:T'=RMPFTP
G SUBE:RMPFTYP=""
S RMPFST="",X=$P(SX,U,3) I X,$D(^RMPF(791810.2,X,0)) S RMPFST=$P(^(0),U,4)
G SUBE:X="" I RMPFORD="S",$D(RMPFP)'=1 G SUBE:'$D(RMPFP(X))
I RMPFORD="P",$D(RMPFP)=10 G SUBE:'$D(RMPFP(X))
I RMPFORD="S" S RMPFNAM="N/A",RMPFSSN="",DFN=$P(SX,U,4) I RMPFTP'="S",DFN D PAT^RMPFUTL
S RMPFAD=$P(SX,U,8),RMPFADP="" I RMPFAD,$D(^VA(200,RMPFAD,0)) S RMPFADP=$P(^(0),U,1)
I RMPFMENU=0 D ARRAY^RMPFDT2 S X=0 F S X=$O(RMPFO(X)) Q:'X I $D(^RMPF(791810,RMPFX,101,X,90)),$P(^(90),U,12) S Y=$P(^(90),U,12) I Y,$D(^VA(200,Y,0)) S RMPFADP=$P(^(0),U,1)
S CT=0,RMPFCX=RMPFCX+1,RMPFS(RMPFCX)=RMPFX
I IOST?1"C-".E,$Y>20 D CONT S:'$D(RMPFX) RMPFOUT="" G SUBE:$D(RMPFOUT) D @("HEAD"_RMPFORD)
I IOST?1"P-".E,$Y>(IOSL-5) D @("HEAD"_RMPFORD)
S RMPFMGG="",X=0 F I=1:1 S X=$O(^RMPF(791810,RMPFX,201,X)) Q:'X S Y=0 F J=1:1 S Y=$O(^RMPF(791810,RMPFX,201,X,101,Y)) Q:'Y I $D(^(Y,0)),'$P(^(0),U,6) S RMPFMGG="***" Q
D @("WRITE"_RMPFORD)
SUBE K S0,SS,SX,Y,RMPFTDP,RMPFTYP,X,TT,RMPFAD,RMPFADP,CT,RMPFMGG
K RMPFO,RMPFSD,RMPFST,T Q
HEADP W @IOF,!?24,"REMOTE ORDER/ENTRY PATIENT ORDERS"
W !,"Station: ",RMPFSTAP,?68,RMPFDAT
W !,"Patient: ",$E(RMPFNAM,1,25),?40,"SSN: ",RMPFSSN,?62,"DOB: ",RMPFDOB
W !!?6,"Status",?46,"Order"
W !?1,"#",?7,"Date",?15,"Status",?23,"Type",?30,"Ord" W $S(RMPFMENU=0:"/Iss",1:"ered") W " By",?46,"Date",?54,"MSG",?65,"Item(s)"
W !,"---",?4,"----------",?15,"------",?22,"------",?29,"-------------",?43,"----------",?54,"---",?58,"----------------------"
Q
WRITEP W !,$J(RMPFCX,2),". ",RMPFSD,?15,RMPFST,?22,RMPFTYP,?29,$E(RMPFADP,1,13),?43,RMPFTDP,?54,RMPFMGG D ARRAY^RMPFDT2 S X=0
W1 S X=$O(RMPFO(X)) G W2:'X
I $D(^RMPF(791810,RMPFX,101,X,0)) S RMPFIT=$P(^(0),U,1) D
.Q:'RMPFIT Q:'$D(^RMPF(791811,RMPFIT,0)) S S0=^(0)
.I RMPFIT=1 S RMPFITP=$P($G(^RMPF(791810,RMPFX,101,X,2)),U,2)
.E S RMPFITP=$E($P(S0,U,1),1,22)
.W:CT ! W ?58,RMPFITP S CT=CT+1
G W1
W2 K RMPFIT,RMPFITP Q
HEADS W @IOF,!?28,"REMOTE ORDER/ENTRY ORDERS"
HEADS1 W !,"Station: ",RMPFSTAP,?68,RMPFDAT
W !!?5,"Status",?68,"Order"
W !,?1,"#",?6,"Date",?15,"Status" W:RMPFTP="S" ?35,"Type"
W:RMPFTP'="S" ?23,"Type",?36,"Patient" W ?53,"Ord" W $S(RMPFMENU=0:"/Iss",1:"ered") W " By",?69,"Date",?77,"MSG"
W !,"---",?4,"----------",?15,"------"
I RMPFTP'="S" W ?22,"------",?29,"----------------------"
E W ?22,"------------------------------"
W ?53,"-----------",?66,"----------",?77,"---"
Q
WRITES W !,$J(RMPFCX,2),". ",RMPFSD,?15,RMPFST
W ?22,$E(RMPFTYP,1,$S(RMPFTP'="S":14,1:28))
W:RMPFTP'="S" ?29,$E(RMPFNAM,1,16) W:RMPFSSN'="" ?46,"-",$E(RMPFSSN,8,11)
W ?53,$E(RMPFADP,1,11),?66,RMPFTDP,?77,RMPFMGG
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)
Q:Y="" D QUE^RMPFDS2:"Pp"[Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFDS1 4797 printed Dec 13, 2024@02:35:47 Page 2
RMPFDS1 ;DDC/KAW-LIST ORDERS BY PATIENT OR STATUS; [ 03/12/98 7:45 AM ]
+1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**8,10,16**;MAY 30, 1995
+2 ;;Reference to ^VA(200) supported by DBIA #10060
+3 ;; input: RMPFTP,RMPFORD,DFN (if RMPFORD="P")
+4 ;;output: RMPFS,RMPFCX,RMPFO
+5 IF $DATA(DFN)
IF DFN
DO PAT^RMPFUTL
+6 DO @("HEAD"_RMPFORD)
SET (RMPF,RMPFCX)=0
+7 IF RMPFORD="S"
FOR I=1:1
SET RMPF=$ORDER(^RMPF(791810,"AD",RMPF))
if 'RMPF
QUIT
if $DATA(RMPFOUT)
GOTO END
SET RMPFX=0
FOR J=1:1
SET RMPFX=$ORDER(^RMPF(791810,"AD",RMPF,RMPFX))
if 'RMPFX
QUIT
DO SUB
if $DATA(RMPFOUT)
GOTO END
if '$DATA(RMPFX)
GOTO END
+8 IF RMPFORD="P"
FOR I=1:1
SET RMPF=$ORDER(^RMPF(791810,"AE",DFN,RMPF))
if RMPF=""
QUIT
if $DATA(RMPFOUT)
GOTO END
SET RMPFX=0
FOR J=1:1
SET RMPFX=$ORDER(^RMPF(791810,"AE",DFN,RMPF,RMPFX))
if 'RMPFX
QUIT
DO SUB
if $DATA(RMPFOUT)
GOTO END
if '$DATA(RMPFX)
GOTO END
+9 if $DATA(RMPFOUT)
GOTO END
+10 if RMPFCX<1
WRITE !!,"NO EXISTING ORDERS"
+11 if RMPFCX
WRITE !!,"Total Orders: ",RMPFCX
+12 if IOST?1"P-".E
WRITE @IOF
+13 if $DATA(IO("S"))
DO ^%ZISC
END KILL RMPFNAM,SSN,RMPFSSN,RMPFDOB,DOB,Y,RMPF,RMPFX,RMPFST,RMPFMGG,RMPFSD
+1 KILL I,J,T,RMPFDOD,OO
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"^"
SET (RMPFOUT,Y)=""
QUIT
+3 if Y?1"?".E
SET (RMPFQUT,Y)=""
+4 QUIT
SUB ;;input: RMPFX,RMPFTP,RMPFORD,RMPFCX,RMPFNAM,RMPFSSN,RMPFDOB,RMPFP (opt), RMPFOO (opt.)
+1 ;;output: RMPFCX,RMPFS
+2 if RMPFX=""
QUIT
+3 if '$DATA(^RMPF(791810,RMPFX,0))
QUIT
SET SX=^(0)
+4 SET X=$PIECE(SX,U,15)
if X=""
SET X=1
SET X=$PIECE(^RMPF(791810.5,X,0),U,2)
if X=""
SET X=1
if X'=RMPFMENU
QUIT
+5 if '$DATA(^RMPF(791810,RMPFX,"STA"))
QUIT
if $PIECE(RMPFSTAP," - ",1)'=$PIECE($PIECE(^("STA"),U,1)," - ",1)
QUIT
+6 IF $DATA(RMPFOO)
Begin DoDot:1
+7 SET OO=$PIECE(SX,U,8)
SET X=0
DO ARRAY^RMPFDT2
+8 FOR
SET X=$ORDER(RMPFO(X))
if 'X
QUIT
IF $DATA(^RMPF(791810,RMPFX,101,X,90))
IF $PIECE(^(90),U,12)
SET OO=$PIECE(^(90),U,12)
End DoDot:1
IF OO
IF OO'=RMPFOO
QUIT
+9 SET Y=$PIECE($PIECE(SX,U,1),".",1)
SET RMPFTDP=$EXTRACT(Y,4,5)_"-"_$EXTRACT(Y,6,7)_"-"_($EXTRACT(Y,1,3)+1700)
+10 SET Y=$PIECE($PIECE(SX,U,6),".",1)
SET RMPFSD=$EXTRACT(Y,4,5)_"-"_$EXTRACT(Y,6,7)_"-"_($EXTRACT(Y,1,3)+1700)
+11 SET RMPFTYP=""
SET X=$PIECE(SX,U,2)
+12 if 'X
GOTO SUBE
if '$DATA(^RMPF(791810.1,X,0))
GOTO SUBE
SET SS=^(0)
+13 SET RMPFTYP=$SELECT(RMPFTP'="S":$PIECE(SS,U,8),1:$PIECE(SS,U,1))
SET T=$PIECE(SS,U,3)
+14 IF RMPFTP'="B"
if T'=RMPFTP
GOTO SUBE
+15 if RMPFTYP=""
GOTO SUBE
+16 SET RMPFST=""
SET X=$PIECE(SX,U,3)
IF X
IF $DATA(^RMPF(791810.2,X,0))
SET RMPFST=$PIECE(^(0),U,4)
+17 if X=""
GOTO SUBE
IF RMPFORD="S"
IF $DATA(RMPFP)'=1
if '$DATA(RMPFP(X))
GOTO SUBE
+18 IF RMPFORD="P"
IF $DATA(RMPFP)=10
if '$DATA(RMPFP(X))
GOTO SUBE
+19 IF RMPFORD="S"
SET RMPFNAM="N/A"
SET RMPFSSN=""
SET DFN=$PIECE(SX,U,4)
IF RMPFTP'="S"
IF DFN
DO PAT^RMPFUTL
+20 SET RMPFAD=$PIECE(SX,U,8)
SET RMPFADP=""
IF RMPFAD
IF $DATA(^VA(200,RMPFAD,0))
SET RMPFADP=$PIECE(^(0),U,1)
+21 IF RMPFMENU=0
DO ARRAY^RMPFDT2
SET X=0
FOR
SET X=$ORDER(RMPFO(X))
if 'X
QUIT
IF $DATA(^RMPF(791810,RMPFX,101,X,90))
IF $PIECE(^(90),U,12)
SET Y=$PIECE(^(90),U,12)
IF Y
IF $DATA(^VA(200,Y,0))
SET RMPFADP=$PIECE(^(0),U,1)
+22 SET CT=0
SET RMPFCX=RMPFCX+1
SET RMPFS(RMPFCX)=RMPFX
+23 IF IOST?1"C-".E
IF $Y>20
DO CONT
if '$DATA(RMPFX)
SET RMPFOUT=""
if $DATA(RMPFOUT)
GOTO SUBE
DO @("HEAD"_RMPFORD)
+24 IF IOST?1"P-".E
IF $Y>(IOSL-5)
DO @("HEAD"_RMPFORD)
+25 SET RMPFMGG=""
SET X=0
FOR I=1:1
SET X=$ORDER(^RMPF(791810,RMPFX,201,X))
if 'X
QUIT
SET Y=0
FOR J=1:1
SET Y=$ORDER(^RMPF(791810,RMPFX,201,X,101,Y))
if 'Y
QUIT
IF $DATA(^(Y,0))
IF '$PIECE(^(0),U,6)
SET RMPFMGG="***"
QUIT
+26 DO @("WRITE"_RMPFORD)
SUBE KILL S0,SS,SX,Y,RMPFTDP,RMPFTYP,X,TT,RMPFAD,RMPFADP,CT,RMPFMGG
+1 KILL RMPFO,RMPFSD,RMPFST,T
QUIT
HEADP WRITE @IOF,!?24,"REMOTE ORDER/ENTRY PATIENT ORDERS"
+1 WRITE !,"Station: ",RMPFSTAP,?68,RMPFDAT
+2 WRITE !,"Patient: ",$EXTRACT(RMPFNAM,1,25),?40,"SSN: ",RMPFSSN,?62,"DOB: ",RMPFDOB
+3 WRITE !!?6,"Status",?46,"Order"
+4 WRITE !?1,"#",?7,"Date",?15,"Status",?23,"Type",?30,"Ord"
WRITE $SELECT(RMPFMENU=0:"/Iss",1:"ered")
WRITE " By",?46,"Date",?54,"MSG",?65,"Item(s)"
+5 WRITE !,"---",?4,"----------",?15,"------",?22,"------",?29,"-------------",?43,"----------",?54,"---",?58,"----------------------"
+6 QUIT
WRITEP WRITE !,$JUSTIFY(RMPFCX,2),". ",RMPFSD,?15,RMPFST,?22,RMPFTYP,?29,$EXTRACT(RMPFADP,1,13),?43,RMPFTDP,?54,RMPFMGG
DO ARRAY^RMPFDT2
SET X=0
W1 SET X=$ORDER(RMPFO(X))
if 'X
GOTO W2
+1 IF $DATA(^RMPF(791810,RMPFX,101,X,0))
SET RMPFIT=$PIECE(^(0),U,1)
Begin DoDot:1
+2 if 'RMPFIT
QUIT
if '$DATA(^RMPF(791811,RMPFIT,0))
QUIT
SET S0=^(0)
+3 IF RMPFIT=1
SET RMPFITP=$PIECE($GET(^RMPF(791810,RMPFX,101,X,2)),U,2)
+4 IF '$TEST
SET RMPFITP=$EXTRACT($PIECE(S0,U,1),1,22)
+5 if CT
WRITE !
WRITE ?58,RMPFITP
SET CT=CT+1
End DoDot:1
+6 GOTO W1
W2 KILL RMPFIT,RMPFITP
QUIT
HEADS WRITE @IOF,!?28,"REMOTE ORDER/ENTRY ORDERS"
HEADS1 WRITE !,"Station: ",RMPFSTAP,?68,RMPFDAT
+1 WRITE !!?5,"Status",?68,"Order"
+2 WRITE !,?1,"#",?6,"Date",?15,"Status"
if RMPFTP="S"
WRITE ?35,"Type"
+3 if RMPFTP'="S"
WRITE ?23,"Type",?36,"Patient"
WRITE ?53,"Ord"
WRITE $SELECT(RMPFMENU=0:"/Iss",1:"ered")
WRITE " By",?69,"Date",?77,"MSG"
+4 WRITE !,"---",?4,"----------",?15,"------"
+5 IF RMPFTP'="S"
WRITE ?22,"------",?29,"----------------------"
+6 IF '$TEST
WRITE ?22,"------------------------------"
+7 WRITE ?53,"-----------",?66,"----------",?77,"---"
+8 QUIT
WRITES WRITE !,$JUSTIFY(RMPFCX,2),". ",RMPFSD,?15,RMPFST
+1 WRITE ?22,$EXTRACT(RMPFTYP,1,$SELECT(RMPFTP'="S":14,1:28))
+2 if RMPFTP'="S"
WRITE ?29,$EXTRACT(RMPFNAM,1,16)
if RMPFSSN'=""
WRITE ?46,"-",$EXTRACT(RMPFSSN,8,11)
+3 WRITE ?53,$EXTRACT(RMPFADP,1,11),?66,RMPFTDP,?77,RMPFMGG
+4 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=""
QUIT
if "Pp"[Y
DO QUE^RMPFDS2
+4 QUIT
