- RMPFDT5 ;DDC/KAW-PATIENT ORDER INFORMATION [ 06/16/95 3:06 PM ]
- ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
- ;;input: RMPFX
- ;;output: RMPFADP,RMPFAPD,RMPFAPP,RMPFDC,RMPFDR,RMPFHAT,RMPFODP,RMPFDDC,RMPFRMK,RMPFST,RMPFSTP,RMPFTF,RMPFTYP,RMPFURP,RMPFUS,RMPFAD
- Q:'$D(^RMPF(791810,RMPFX,0))
- D ^RMPFET3 S Y=DT D DD^%DT S RMPFDAT=Y
- S S0=^RMPF(791810,RMPFX,0),Y=$P(S0,U,1) D DD^%DT S RMPFTDP=Y
- S DFN=$P(S0,U,4)
- S (RMPFTYP,RMPFHAT)="",RMPFTYP=$P(S0,U,2) I RMPFTYP,$D(^RMPF(791810.1,RMPFTYP,0)) S RMPFTYPP=$P(^(0),U,1),RMPFHAT=$P(^(0),U,2),RMPFTP=$P(^(0),U,3)
- I RMPFTYP=""!(RMPFHAT="") W $C(7),!!,"ERROR IN ORDER TYPE" G END
- S RMPFSTP="",RMPFST=$P(^RMPF(791810,RMPFX,0),U,3) I RMPFST,$D(^RMPF(791810.2,RMPFST,0)) S RMPFSTP=$P(^(0),U,1)
- S RMPFUR=$P(S0,U,5),RMPFURP="" I RMPFUR,$D(^VA(200,RMPFUR,0)) S RMPFURP=$P(^(0),U,1)
- S RMPFAD=$P(S0,U,8),RMPFADP="" I RMPFAD,$D(^VA(200,RMPFAD,0)) S RMPFADP=$P(^(0),U,1)
- S RMPFOD=$P(S0,U,9),RMPFODP="" I RMPFOD?7N S Y=RMPFOD D DD^%DT S RMPFODP=Y
- S RMPFAP=$P(S0,U,10),RMPFAPP="" I RMPFAP,$D(^VA(200,RMPFAP,0)) S RMPFAPP=$P(^(0),U,1)
- S RMPFAPD="",X=$P(S0,U,11) I X S Y=X D DD^%DT S RMPFAPD=Y
- S RMPFPO=$P(S0,U,7),RMPFINV=$P(S0,U,13),Y=$P(S0,U,14)
- D DD^%DT S RMPFRDC=Y
- S S1=$S($D(^RMPF(791810,RMPFX,11)):^(11),1:"")
- S RMPFTF=$P(S1,U,1),RMPFTF=$S(RMPFTF="M":"MONAURAL",RMPFTF="B":"BINAURAL",RMPFTF="C":"CROS",RMPFTF="BC":"BI-CROS",1:"")
- S RMPFUS=$P(S1,U,2),RMPFUS=$S(RMPFUS="M":"MONAURAL",RMPFUS="B":"BINAURAL",1:"")
- S RMPFDDC=$P(S1,U,3),RMPFDDC=$S(RMPFDDC:"YES",RMPFDDC=0:"NO",1:"")
- S S2=$G(^RMPF(791810,RMPFX,2)),RMPFDC=$P(S2,U,1) I RMPFDC,$D(^RMPR(662,RMPFDC,0)) S RMPFDC=$P(^(0),U,1)
- S RMPFTE=$P(S2,U,2) I RMPFTE,$D(^RMPF(791810.4,RMPFTE,0)) S RMPFTE=$P(^(0),U,1)
- S X=$G(^RMPF(791810,RMPFX,10)),RMPFCAT=$P(X,U,5),RMPFCAR=$P(X,U,4)
- S RMPFCAT=$S(RMPFCAT="R":"ROUTINE",RMPFCAT="E":"EMERGENCY",RMPFCAT="P":"PRIORITY",1:"")
- I RMPFCAR S Y=RMPFCAR D DD^%DT S RMPFCAR=Y
- S RMPFRMK=$P(X,U,1),RMPFCUR=$P(X,U,3),RMPFCARE=$P(X,U,8)
- I RMPFCARE S Y=RMPFCARE D DD^%DT S RMPFCARE=Y
- S RMPFDR=$P(X,U,2)
- K RMPFTA I $D(^RMPF(791810,RMPFX,1)) S SA=^(1),RMPFTA="" F I=4:1:6 I $P(SA,U,I)="" K RMPFTA Q
- END K RMPFAP,RMPFUR,S1,SA,A,S0,Y,X
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFDT5 2206 printed Feb 19, 2025@00:02:26 Page 2
- RMPFDT5 ;DDC/KAW-PATIENT ORDER INFORMATION [ 06/16/95 3:06 PM ]
- +1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
- +2 ;;input: RMPFX
- +3 ;;output: RMPFADP,RMPFAPD,RMPFAPP,RMPFDC,RMPFDR,RMPFHAT,RMPFODP,RMPFDDC,RMPFRMK,RMPFST,RMPFSTP,RMPFTF,RMPFTYP,RMPFURP,RMPFUS,RMPFAD
- +4 if '$DATA(^RMPF(791810,RMPFX,0))
- QUIT
- +5 DO ^RMPFET3
- SET Y=DT
- DO DD^%DT
- SET RMPFDAT=Y
- +6 SET S0=^RMPF(791810,RMPFX,0)
- SET Y=$PIECE(S0,U,1)
- DO DD^%DT
- SET RMPFTDP=Y
- +7 SET DFN=$PIECE(S0,U,4)
- +8 SET (RMPFTYP,RMPFHAT)=""
- SET RMPFTYP=$PIECE(S0,U,2)
- IF RMPFTYP
- IF $DATA(^RMPF(791810.1,RMPFTYP,0))
- SET RMPFTYPP=$PIECE(^(0),U,1)
- SET RMPFHAT=$PIECE(^(0),U,2)
- SET RMPFTP=$PIECE(^(0),U,3)
- +9 IF RMPFTYP=""!(RMPFHAT="")
- WRITE $CHAR(7),!!,"ERROR IN ORDER TYPE"
- GOTO END
- +10 SET RMPFSTP=""
- SET RMPFST=$PIECE(^RMPF(791810,RMPFX,0),U,3)
- IF RMPFST
- IF $DATA(^RMPF(791810.2,RMPFST,0))
- SET RMPFSTP=$PIECE(^(0),U,1)
- +11 SET RMPFUR=$PIECE(S0,U,5)
- SET RMPFURP=""
- IF RMPFUR
- IF $DATA(^VA(200,RMPFUR,0))
- SET RMPFURP=$PIECE(^(0),U,1)
- +12 SET RMPFAD=$PIECE(S0,U,8)
- SET RMPFADP=""
- IF RMPFAD
- IF $DATA(^VA(200,RMPFAD,0))
- SET RMPFADP=$PIECE(^(0),U,1)
- +13 SET RMPFOD=$PIECE(S0,U,9)
- SET RMPFODP=""
- IF RMPFOD?7N
- SET Y=RMPFOD
- DO DD^%DT
- SET RMPFODP=Y
- +14 SET RMPFAP=$PIECE(S0,U,10)
- SET RMPFAPP=""
- IF RMPFAP
- IF $DATA(^VA(200,RMPFAP,0))
- SET RMPFAPP=$PIECE(^(0),U,1)
- +15 SET RMPFAPD=""
- SET X=$PIECE(S0,U,11)
- IF X
- SET Y=X
- DO DD^%DT
- SET RMPFAPD=Y
- +16 SET RMPFPO=$PIECE(S0,U,7)
- SET RMPFINV=$PIECE(S0,U,13)
- SET Y=$PIECE(S0,U,14)
- +17 DO DD^%DT
- SET RMPFRDC=Y
- +18 SET S1=$SELECT($DATA(^RMPF(791810,RMPFX,11)):^(11),1:"")
- +19 SET RMPFTF=$PIECE(S1,U,1)
- SET RMPFTF=$SELECT(RMPFTF="M":"MONAURAL",RMPFTF="B":"BINAURAL",RMPFTF="C":"CROS",RMPFTF="BC":"BI-CROS",1:"")
- +20 SET RMPFUS=$PIECE(S1,U,2)
- SET RMPFUS=$SELECT(RMPFUS="M":"MONAURAL",RMPFUS="B":"BINAURAL",1:"")
- +21 SET RMPFDDC=$PIECE(S1,U,3)
- SET RMPFDDC=$SELECT(RMPFDDC:"YES",RMPFDDC=0:"NO",1:"")
- +22 SET S2=$GET(^RMPF(791810,RMPFX,2))
- SET RMPFDC=$PIECE(S2,U,1)
- IF RMPFDC
- IF $DATA(^RMPR(662,RMPFDC,0))
- SET RMPFDC=$PIECE(^(0),U,1)
- +23 SET RMPFTE=$PIECE(S2,U,2)
- IF RMPFTE
- IF $DATA(^RMPF(791810.4,RMPFTE,0))
- SET RMPFTE=$PIECE(^(0),U,1)
- +24 SET X=$GET(^RMPF(791810,RMPFX,10))
- SET RMPFCAT=$PIECE(X,U,5)
- SET RMPFCAR=$PIECE(X,U,4)
- +25 SET RMPFCAT=$SELECT(RMPFCAT="R":"ROUTINE",RMPFCAT="E":"EMERGENCY",RMPFCAT="P":"PRIORITY",1:"")
- +26 IF RMPFCAR
- SET Y=RMPFCAR
- DO DD^%DT
- SET RMPFCAR=Y
- +27 SET RMPFRMK=$PIECE(X,U,1)
- SET RMPFCUR=$PIECE(X,U,3)
- SET RMPFCARE=$PIECE(X,U,8)
- +28 IF RMPFCARE
- SET Y=RMPFCARE
- DO DD^%DT
- SET RMPFCARE=Y
- +29 SET RMPFDR=$PIECE(X,U,2)
- +30 KILL RMPFTA
- IF $DATA(^RMPF(791810,RMPFX,1))
- SET SA=^(1)
- SET RMPFTA=""
- FOR I=4:1:6
- IF $PIECE(SA,U,I)=""
- KILL RMPFTA
- QUIT
- END KILL RMPFAP,RMPFUR,S1,SA,A,S0,Y,X
- +1 QUIT
