- 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 Jan 18, 2025@03:36:57 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