Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RMPFDS1

RMPFDS1.m

Go to the documentation of this file.
  1. 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
  1. ;;Reference to ^VA(200) supported by DBIA #10060
  1. ;; input: RMPFTP,RMPFORD,DFN (if RMPFORD="P")
  1. ;;output: RMPFS,RMPFCX,RMPFO
  1. I $D(DFN),DFN D PAT^RMPFUTL
  1. D @("HEAD"_RMPFORD) S (RMPF,RMPFCX)=0
  1. 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)
  1. 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)
  1. G END:$D(RMPFOUT)
  1. W:RMPFCX<1 !!,"NO EXISTING ORDERS"
  1. W:RMPFCX !!,"Total Orders: ",RMPFCX
  1. W:IOST?1"P-".E @IOF
  1. D:$D(IO("S")) ^%ZISC
  1. END K RMPFNAM,SSN,RMPFSSN,RMPFDOB,DOB,Y,RMPF,RMPFX,RMPFST,RMPFMGG,RMPFSD
  1. K I,J,T,RMPFDOD,OO Q
  1. READ K RMPFOUT,RMPFQUT
  1. R Y:DTIME I '$T W $C(7) R Y:5 G READ:Y="." S:'$T Y=U
  1. I Y?1"^" S (RMPFOUT,Y)="" Q
  1. S:Y?1"?".E (RMPFQUT,Y)=""
  1. Q
  1. SUB ;;input: RMPFX,RMPFTP,RMPFORD,RMPFCX,RMPFNAM,RMPFSSN,RMPFDOB,RMPFP (opt), RMPFOO (opt.)
  1. ;;output: RMPFCX,RMPFS
  1. Q:RMPFX=""
  1. Q:'$D(^RMPF(791810,RMPFX,0)) S SX=^(0)
  1. 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
  1. Q:'$D(^RMPF(791810,RMPFX,"STA")) Q:$P(RMPFSTAP," - ",1)'=$P($P(^("STA"),U,1)," - ",1)
  1. I $D(RMPFOO) D I OO,OO'=RMPFOO Q
  1. .S OO=$P(SX,U,8),X=0 D ARRAY^RMPFDT2
  1. .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)
  1. S Y=$P($P(SX,U,1),".",1),RMPFTDP=$E(Y,4,5)_"-"_$E(Y,6,7)_"-"_($E(Y,1,3)+1700)
  1. S Y=$P($P(SX,U,6),".",1),RMPFSD=$E(Y,4,5)_"-"_$E(Y,6,7)_"-"_($E(Y,1,3)+1700)
  1. S RMPFTYP="",X=$P(SX,U,2)
  1. G SUBE:'X,SUBE:'$D(^RMPF(791810.1,X,0)) S SS=^(0)
  1. S RMPFTYP=$S(RMPFTP'="S":$P(SS,U,8),1:$P(SS,U,1)),T=$P(SS,U,3)
  1. I RMPFTP'="B" G SUBE:T'=RMPFTP
  1. G SUBE:RMPFTYP=""
  1. S RMPFST="",X=$P(SX,U,3) I X,$D(^RMPF(791810.2,X,0)) S RMPFST=$P(^(0),U,4)
  1. G SUBE:X="" I RMPFORD="S",$D(RMPFP)'=1 G SUBE:'$D(RMPFP(X))
  1. I RMPFORD="P",$D(RMPFP)=10 G SUBE:'$D(RMPFP(X))
  1. I RMPFORD="S" S RMPFNAM="N/A",RMPFSSN="",DFN=$P(SX,U,4) I RMPFTP'="S",DFN D PAT^RMPFUTL
  1. S RMPFAD=$P(SX,U,8),RMPFADP="" I RMPFAD,$D(^VA(200,RMPFAD,0)) S RMPFADP=$P(^(0),U,1)
  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)
  1. S CT=0,RMPFCX=RMPFCX+1,RMPFS(RMPFCX)=RMPFX
  1. I IOST?1"C-".E,$Y>20 D CONT S:'$D(RMPFX) RMPFOUT="" G SUBE:$D(RMPFOUT) D @("HEAD"_RMPFORD)
  1. I IOST?1"P-".E,$Y>(IOSL-5) D @("HEAD"_RMPFORD)
  1. 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
  1. D @("WRITE"_RMPFORD)
  1. SUBE K S0,SS,SX,Y,RMPFTDP,RMPFTYP,X,TT,RMPFAD,RMPFADP,CT,RMPFMGG
  1. K RMPFO,RMPFSD,RMPFST,T Q
  1. HEADP W @IOF,!?24,"REMOTE ORDER/ENTRY PATIENT ORDERS"
  1. W !,"Station: ",RMPFSTAP,?68,RMPFDAT
  1. W !,"Patient: ",$E(RMPFNAM,1,25),?40,"SSN: ",RMPFSSN,?62,"DOB: ",RMPFDOB
  1. W !!?6,"Status",?46,"Order"
  1. 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)"
  1. W !,"---",?4,"----------",?15,"------",?22,"------",?29,"-------------",?43,"----------",?54,"---",?58,"----------------------"
  1. Q
  1. 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
  1. W1 S X=$O(RMPFO(X)) G W2:'X
  1. I $D(^RMPF(791810,RMPFX,101,X,0)) S RMPFIT=$P(^(0),U,1) D
  1. .Q:'RMPFIT Q:'$D(^RMPF(791811,RMPFIT,0)) S S0=^(0)
  1. .I RMPFIT=1 S RMPFITP=$P($G(^RMPF(791810,RMPFX,101,X,2)),U,2)
  1. .E S RMPFITP=$E($P(S0,U,1),1,22)
  1. .W:CT ! W ?58,RMPFITP S CT=CT+1
  1. G W1
  1. W2 K RMPFIT,RMPFITP Q
  1. HEADS W @IOF,!?28,"REMOTE ORDER/ENTRY ORDERS"
  1. HEADS1 W !,"Station: ",RMPFSTAP,?68,RMPFDAT
  1. W !!?5,"Status",?68,"Order"
  1. W !,?1,"#",?6,"Date",?15,"Status" W:RMPFTP="S" ?35,"Type"
  1. W:RMPFTP'="S" ?23,"Type",?36,"Patient" W ?53,"Ord" W $S(RMPFMENU=0:"/Iss",1:"ered") W " By",?69,"Date",?77,"MSG"
  1. W !,"---",?4,"----------",?15,"------"
  1. I RMPFTP'="S" W ?22,"------",?29,"----------------------"
  1. E W ?22,"------------------------------"
  1. W ?53,"-----------",?66,"----------",?77,"---"
  1. Q
  1. WRITES W !,$J(RMPFCX,2),". ",RMPFSD,?15,RMPFST
  1. W ?22,$E(RMPFTYP,1,$S(RMPFTP'="S":14,1:28))
  1. W:RMPFTP'="S" ?29,$E(RMPFNAM,1,16) W:RMPFSSN'="" ?46,"-",$E(RMPFSSN,8,11)
  1. W ?53,$E(RMPFADP,1,11),?66,RMPFTDP,?77,RMPFMGG
  1. Q
  1. CONT F I=1:1 Q:$Y>20 W !
  1. W !,"Type <RETURN> to continue, <P>rint or <^> to exit: " D READ
  1. Q:$D(RMPFOUT) G CONT:$D(RMPFQUT)
  1. Q:Y="" D QUE^RMPFDS2:"Pp"[Y
  1. Q