- RMPFDT1 ;DDC/KAW-PATIENT ORDER INFORMATION; [ 06/16/95 3:06 PM ]
- ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
- ;;input: RMPFX,RMPFTE (for patient types)
- ;;output: RMPFTYP,RMPFST,RMPFHAT,RMPFTP
- I $D(RMPFX),RMPFX,$D(^RMPF(791810,RMPFX,0))
- E Q
- S (RMPFNAM,RMPFDOB,RMPFSSN)="",S0=^RMPF(791810,RMPFX,0)
- S DFN=$P(S0,U,4) I DFN D PAT^RMPFUTL
- S RMPFTYP=$P(S0,U,2),RMPFST=$P(S0,U,3)
- I RMPFTYP,$D(^RMPF(791810.1,RMPFTYP,0)) S RMPFHAT=$P(^(0),U,2),RMPFTP=$P(^(0),U,3)
- D ^RMPFDT5 G END:$D(RMPFOUT)
- G END:"PS"'[RMPFTP D @("HEAD"_RMPFTP),DISP
- END K RMPFNAM,RMPFSSN,RMPFDOB,RMPFDOD,RMPFY,RMPFOD,RMPFMSG,CN Q
- DISP S CN=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
- W ! I $D(RMPFMGG),RMPFMGG'="" W ?29,"*** UNREAD MESSAGE ***"
- F I=1:1 S X=$P($T(PROMPT+I),";;",2) Q:X="" D
- .X X
- .Q:'$D(^RMPF(791810.1,RMPFTYP,100,CN,0)) S Y=$P(^(0),U,4),Z=$P(^(0),U,5)
- .Q:Y=""!(Z="")!(Z="RMPFRMK") I $D(RMPFEDIT) W:$X>47 ! W ?43,"[",CN,"]"
- .W:$X>47 ! W ?47,$J(Y,12),": ",$E(@Z,1,19) S CN=CN+1
- S CR=CN-1 F L=1:1 S CR=$O(^RMPF(791810.1,RMPFTYP,100,CR)) Q:'CR D
- .I $P(^RMPF(791810.1,RMPFTYP,100,CR,0),U,2)["RMPFMOD" W ! D ^RMPFDT2 Q
- .S Y=$P(^RMPF(791810.1,RMPFTYP,100,CR,0),U,4),Z=$P(^(0),U,5)
- .Q:Y=""!(Z="") W !
- .I $D(RMPFEDIT) W:$X>47 ! W:Z'="RMPFRMK" ?43 W "[",CN,"]"
- .W:$X>47 ! W:Z'="RMPFRMK" ?47 W:Z="RMPFRMK" ?2 W $J(Y,$S(Z'="RMPFRMK":12,1:8)),": ",$E(@Z,1,$S(Z'="RMPFRMK":19,1:70)) S CN=CN+1
- CON W:$D(RMPFTA) !?27,"*** ROES Address ***"
- I $D(RMPFERR) W !!,"Missing Required Information:" D
- .S X=0 F I=1:1 S X=$O(RMPFERR(X)) Q:X="" W $C(7),!,"*** ",X," ***" I $Y>18,$O(RMPFERR(X))!$D(RMPFMSG) D CONT^RMPFDT2 Q:$D(RMPFOUT) W @IOF
- I $D(RMPFMSG) W !!,"Message:" D
- .S X=0 F I=1:1 S X=$O(RMPFMSG(X)) Q:X="" W $C(7),!,X I $Y>19,$O(RMPFMSG(X)) D CONT^RMPFDT2 Q:$D(RMPFOUT) W @IOF
- S X=$P(^RMPF(791810.1,RMPFTYP,0),U,5) I $L(X) D CONT^RMPFDT2:$Y>19 S X="*** "_X_" ***" W $C(7),!!,?80-$L(X)\2,X
- W:IOST?1"P-".E @IOF
- D:$D(IO("S")) ^%ZISC
- DISPE K RMPFADP,RMPFAPD,RMPFAPP,RMPFDC,RMPFDR,RMPFODP,RMPFDDC,RMPFDIS
- K RMPFRMK,RMPFSTP,RMPFTF,RMPFURP,RMPFUS,RMPFCAT,RMPFCERD,RMPFCERU
- K RMPFTDP,RMPFCUR,RMPFINV,RMPFMD,RMPFPO,RMPFRDC,RMPFDSN
- K RMPFTA,RMPFTYPP,RMPFLIS,RMPFMGG,RMPFO,RMPFPCT,RMPFPG,RMPFPSC,RMPFTT
- K RMPFAD,S4,X,Y,L,CX,CR,Z Q
- HEADP W @IOF,!?22,"REMOTE ORDER/ENTRY ORDER INFORMATION"
- HEADP1 W !,"Station: ",RMPFSTAP,?68,RMPFDAT
- W !,"Patient: ",$E(RMPFNAM,1,25),?40,"SSN: ",RMPFSSN,?62,"DOB: ",RMPFDOB
- W ! F I=1:1:80 W "-"
- Q
- HEADS W @IOF,!!?18,"REMOTE ORDER/ENTRY STATION ORDER INFORMATION"
- W !,"Station: ",RMPFSTAP,?68,RMPFDAT
- W ! F I=1:1:80 W "-"
- Q
- PROMPT ;;
- ;;W !?1,"Order Date/Time: ",RMPFTDP
- ;;W !?6,"Order Type: ",$E(RMPFTYPP,1,23)
- ;;W !?10,"Status: ",$E(RMPFSTP,1,23)
- ;;W !?6,"Entered By: ",$E(RMPFURP,1,23)
- ;;W:RMPFTP="P" !?5,"Eligibility: ",$E($P(RMPFTE,U,1),1,23)
- ;;W:RMPFAPP'="" !?2,$S(RMPFST'=7:" Approved ",1:"Disapproved "),"By: ",$E(RMPFAPP,1,23)
- ;;I RMPFAPD'="" W:RMPFST=7 !,"Disapproval Date: " W:RMPFST'=7 !?3,"Approval Date: " W RMPFAPD
- ;;W:RMPFDR'="" !,$S(RMPFST'=7:"Approval ",1:"Disapprov "),"Reason: ",$E(RMPFDR,1,23)
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFDT1 3248 printed Jan 18, 2025@03:37 Page 2
- RMPFDT1 ;DDC/KAW-PATIENT ORDER INFORMATION; [ 06/16/95 3:06 PM ]
- +1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
- +2 ;;input: RMPFX,RMPFTE (for patient types)
- +3 ;;output: RMPFTYP,RMPFST,RMPFHAT,RMPFTP
- +4 IF $DATA(RMPFX)
- IF RMPFX
- IF $DATA(^RMPF(791810,RMPFX,0))
- +5 IF '$TEST
- QUIT
- +6 SET (RMPFNAM,RMPFDOB,RMPFSSN)=""
- SET S0=^RMPF(791810,RMPFX,0)
- +7 SET DFN=$PIECE(S0,U,4)
- IF DFN
- DO PAT^RMPFUTL
- +8 SET RMPFTYP=$PIECE(S0,U,2)
- SET RMPFST=$PIECE(S0,U,3)
- +9 IF RMPFTYP
- IF $DATA(^RMPF(791810.1,RMPFTYP,0))
- SET RMPFHAT=$PIECE(^(0),U,2)
- SET RMPFTP=$PIECE(^(0),U,3)
- +10 DO ^RMPFDT5
- if $DATA(RMPFOUT)
- GOTO END
- +11 if "PS"'[RMPFTP
- GOTO END
- DO @("HEAD"_RMPFTP)
- DO DISP
- END KILL RMPFNAM,RMPFSSN,RMPFDOB,RMPFDOD,RMPFY,RMPFOD,RMPFMSG,CN
- QUIT
- DISP SET CN=1
- +1 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
- +2 WRITE !
- IF $DATA(RMPFMGG)
- IF RMPFMGG'=""
- WRITE ?29,"*** UNREAD MESSAGE ***"
- +3 FOR I=1:1
- SET X=$PIECE($TEXT(PROMPT+I),";;",2)
- if X=""
- QUIT
- Begin DoDot:1
- +4 XECUTE X
- +5 if '$DATA(^RMPF(791810.1,RMPFTYP,100,CN,0))
- QUIT
- SET Y=$PIECE(^(0),U,4)
- SET Z=$PIECE(^(0),U,5)
- +6 if Y=""!(Z="")!(Z="RMPFRMK")
- QUIT
- IF $DATA(RMPFEDIT)
- if $X>47
- WRITE !
- WRITE ?43,"[",CN,"]"
- +7 if $X>47
- WRITE !
- WRITE ?47,$JUSTIFY(Y,12),": ",$EXTRACT(@Z,1,19)
- SET CN=CN+1
- End DoDot:1
- +8 SET CR=CN-1
- FOR L=1:1
- SET CR=$ORDER(^RMPF(791810.1,RMPFTYP,100,CR))
- if 'CR
- QUIT
- Begin DoDot:1
- +9 IF $PIECE(^RMPF(791810.1,RMPFTYP,100,CR,0),U,2)["RMPFMOD"
- WRITE !
- DO ^RMPFDT2
- QUIT
- +10 SET Y=$PIECE(^RMPF(791810.1,RMPFTYP,100,CR,0),U,4)
- SET Z=$PIECE(^(0),U,5)
- +11 if Y=""!(Z="")
- QUIT
- WRITE !
- +12 IF $DATA(RMPFEDIT)
- if $X>47
- WRITE !
- if Z'="RMPFRMK"
- WRITE ?43
- WRITE "[",CN,"]"
- +13 if $X>47
- WRITE !
- if Z'="RMPFRMK"
- WRITE ?47
- if Z="RMPFRMK"
- WRITE ?2
- WRITE $JUSTIFY(Y,$SELECT(Z'="RMPFRMK":12,1:8)),": ",$EXTRACT(@Z,1,$SELECT(Z'="RMPFRMK":19,1:70))
- SET CN=CN+1
- End DoDot:1
- CON if $DATA(RMPFTA)
- WRITE !?27,"*** ROES Address ***"
- +1 IF $DATA(RMPFERR)
- WRITE !!,"Missing Required Information:"
- Begin DoDot:1
- +2 SET X=0
- FOR I=1:1
- SET X=$ORDER(RMPFERR(X))
- if X=""
- QUIT
- WRITE $CHAR(7),!,"*** ",X," ***"
- IF $Y>18
- IF $ORDER(RMPFERR(X))!$DATA(RMPFMSG)
- DO CONT^RMPFDT2
- if $DATA(RMPFOUT)
- QUIT
- WRITE @IOF
- End DoDot:1
- +3 IF $DATA(RMPFMSG)
- WRITE !!,"Message:"
- Begin DoDot:1
- +4 SET X=0
- FOR I=1:1
- SET X=$ORDER(RMPFMSG(X))
- if X=""
- QUIT
- WRITE $CHAR(7),!,X
- IF $Y>19
- IF $ORDER(RMPFMSG(X))
- DO CONT^RMPFDT2
- if $DATA(RMPFOUT)
- QUIT
- WRITE @IOF
- End DoDot:1
- +5 SET X=$PIECE(^RMPF(791810.1,RMPFTYP,0),U,5)
- IF $LENGTH(X)
- if $Y>19
- DO CONT^RMPFDT2
- SET X="*** "_X_" ***"
- WRITE $CHAR(7),!!,?80-$LENGTH(X)\2,X
- +6 if IOST?1"P-".E
- WRITE @IOF
- +7 if $DATA(IO("S"))
- DO ^%ZISC
- DISPE KILL RMPFADP,RMPFAPD,RMPFAPP,RMPFDC,RMPFDR,RMPFODP,RMPFDDC,RMPFDIS
- +1 KILL RMPFRMK,RMPFSTP,RMPFTF,RMPFURP,RMPFUS,RMPFCAT,RMPFCERD,RMPFCERU
- +2 KILL RMPFTDP,RMPFCUR,RMPFINV,RMPFMD,RMPFPO,RMPFRDC,RMPFDSN
- +3 KILL RMPFTA,RMPFTYPP,RMPFLIS,RMPFMGG,RMPFO,RMPFPCT,RMPFPG,RMPFPSC,RMPFTT
- +4 KILL RMPFAD,S4,X,Y,L,CX,CR,Z
- QUIT
- HEADP WRITE @IOF,!?22,"REMOTE ORDER/ENTRY ORDER INFORMATION"
- HEADP1 WRITE !,"Station: ",RMPFSTAP,?68,RMPFDAT
- +1 WRITE !,"Patient: ",$EXTRACT(RMPFNAM,1,25),?40,"SSN: ",RMPFSSN,?62,"DOB: ",RMPFDOB
- +2 WRITE !
- FOR I=1:1:80
- WRITE "-"
- +3 QUIT
- HEADS WRITE @IOF,!!?18,"REMOTE ORDER/ENTRY STATION ORDER INFORMATION"
- +1 WRITE !,"Station: ",RMPFSTAP,?68,RMPFDAT
- +2 WRITE !
- FOR I=1:1:80
- WRITE "-"
- +3 QUIT
- PROMPT ;;
- +1 ;;W !?1,"Order Date/Time: ",RMPFTDP
- +2 ;;W !?6,"Order Type: ",$E(RMPFTYPP,1,23)
- +3 ;;W !?10,"Status: ",$E(RMPFSTP,1,23)
- +4 ;;W !?6,"Entered By: ",$E(RMPFURP,1,23)
- +5 ;;W:RMPFTP="P" !?5,"Eligibility: ",$E($P(RMPFTE,U,1),1,23)
- +6 ;;W:RMPFAPP'="" !?2,$S(RMPFST'=7:" Approved ",1:"Disapproved "),"By: ",$E(RMPFAPP,1,23)
- +7 ;;I RMPFAPD'="" W:RMPFST=7 !,"Disapproval Date: " W:RMPFST'=7 !?3,"Approval Date: " W RMPFAPD
- +8 ;;W:RMPFDR'="" !,$S(RMPFST'=7:"Approval ",1:"Disapprov "),"Reason: ",$E(RMPFDR,1,23)