- RMPFQP1 ;DDC/KAW-PRINT VA FORM 10-2477a [ 06/16/95 3:06 PM ]
- ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
- ; input: RMPFSTAN
- ;output: RMPFR,RMPFS,RMPFRSTA
- ISS S X=RMPFSTAN I X,$D(^DIC(4,X,0)) S ST=X,TY="S" D STA
- S RMPFRSTA=""
- REG S X=$S($D(^RMPF(791813,RMPFSTAN,2)):$P(^(2),U,1),1:"") I X,$D(^DIC(4,X,0)) S RMPFRSTA=$S($D(^DIC(4,X,99)):$P(^(99),U,1),1:""),TY="R",ST=X D STA
- END K RS,R,TY,ST,I,X,Y Q
- STA ;; input: ST,TY
- ;;output: RMPFR or RMPFS
- S CT=1 K @("RMPF"_TY) S S0=^DIC(4,ST,0)
- S S="",X=$P(S0,U,2) I X,$D(^DIC(5,X,0)) S S=$P(^(0),U,2)
- S RS="" I $D(^RMPF(791813,RMPFSTAN,2)) S R=$P(^(2),U,2),RS=$S(R'="":"("_R_")",1:"")
- S @("RMPF"_TY_"(1)")=$S($P(S0,U,4)'="":$P(S0,U,4),1:"VA MEDICAL CENTER")_" "_RS,S1=$S($D(^DIC(4,ST,1)):^(1),1:"")
- F I=1:1:2 S X=$P(S1,U,I) I X'="" S CT=CT+1,@("RMPF"_TY_"("_CT_")")=X
- S C=$P(S1,U,3),Z=$P(S1,U,4),CT=CT+1
- S @("RMPF"_TY_"("_CT_")")=$E(C,1,21)_", "_S_" "_Z
- K C,CT,Z,S,X,S0,S1,I,Z Q
- MOD D ARRAY^RMPFDT2 S RMPFY=0
- D1 S RMPFY=$O(RMPFO(RMPFY)) G END1:RMPFY="" G D1:'$D(^RMPF(791810,RMPFX,101,RMPFY,0)) S S1=^(0),RMPFIT=$P(S1,U,1)
- G D1:'RMPFIT,D1:'$D(^RMPF(791811,RMPFIT,0)) S S2=^(0),RMPFITP=$P(S2,U,1),RMPFMAK=$P(S2,U,2)
- I RMPFITP="NON-CONTRACT",$D(^RMPF(791810,RMPFX,101,RMPFY,2)) S RMPFITP=$P(^(2),U,2),RMPFMAK=$P(^(2),U,1)
- S RMPFNSN=$P($P(S2,U,5),"-",3,4)
- S RMPFSN=$P(S1,U,5),RMPFBAT=$P(S1,U,2) I RMPFBAT,$D(^RMPF(791811.3,RMPFBAT,0)) S RMPFBAT=$P(^(0),U,1)
- S RMPFBAT2="" I $D(^RMPF(791810,RMPFX,101,RMPFY,2)) S RMPFBAT2=$P(^(2),U,3) I RMPFBAT2,$D(^RMPF(791811.3,RMPFBAT2,0)) S RMPFBAT2=$P(^(0),U,1)
- S RMPFIDP="",Y=$P(S1,U,8)
- I Y D DD^%DT S RMPFIDP=Y
- S RMPFREP=$S($D(^RMPF(791810,RMPFX,11)):$P(^(11),U,3),1:"")
- MODEL W !,"6515-01-",RMPFNSN
- W ?16,"|",?17,$E(RMPFMAK,1,10)
- W ?27,"|",?28,$E(RMPFITP,1,16)
- W ?44,"|",?46,$E(RMPFSN,1,10)
- W ?57,"|",?59,$E(RMPFBAT,1,7)
- W ?67,"|" S (X,CT)=0
- F I=1:1 S X=$O(^RMPF(791810,RMPFX,101,RMPFY,101,X)) Q:'X D
- .Q:'$D(^RMPF(791810,RMPFX,101,RMPFY,101,X,0)) S SN=$P(^(0),U,1)
- .I 'CT W ?69,$E(SN,1,11) S CT=CT+1 Q
- .W !,?16,"|",?27,"|",?44,"|",?57,"|"
- .I $D(RMPFBAT2),RMPFBAT2'="" W ?59,$E(RMPFBAT2,1,7) K RMPFBAT2
- .W ?67,"|",?69,$E(SN,1,11)
- .Q
- I $D(RMPFBAT2),RMPFBAT2'="" W !?16,"|",?27,"|",?44,"|",?57,"|",?59,$E(RMPFBAT2,1,7),?67,"|"
- D LINE^RMPFQP3
- G D1
- END1 K RMPFY,RMPFIT,RMPFITP,RMPFMAK,RMPFNSN,RMPFSN,RMPFBAT
- K RMPFIDP,RMPFRSN,CT,SN,S1,I,S2,X Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFQP1 2405 printed Apr 23, 2025@18:51:22 Page 2
- RMPFQP1 ;DDC/KAW-PRINT VA FORM 10-2477a [ 06/16/95 3:06 PM ]
- +1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
- +2 ; input: RMPFSTAN
- +3 ;output: RMPFR,RMPFS,RMPFRSTA
- ISS SET X=RMPFSTAN
- IF X
- IF $DATA(^DIC(4,X,0))
- SET ST=X
- SET TY="S"
- DO STA
- +1 SET RMPFRSTA=""
- REG SET X=$SELECT($DATA(^RMPF(791813,RMPFSTAN,2)):$PIECE(^(2),U,1),1:"")
- IF X
- IF $DATA(^DIC(4,X,0))
- SET RMPFRSTA=$SELECT($DATA(^DIC(4,X,99)):$PIECE(^(99),U,1),1:"")
- SET TY="R"
- SET ST=X
- DO STA
- END KILL RS,R,TY,ST,I,X,Y
- QUIT
- STA ;; input: ST,TY
- +1 ;;output: RMPFR or RMPFS
- +2 SET CT=1
- KILL @("RMPF"_TY)
- SET S0=^DIC(4,ST,0)
- +3 SET S=""
- SET X=$PIECE(S0,U,2)
- IF X
- IF $DATA(^DIC(5,X,0))
- SET S=$PIECE(^(0),U,2)
- +4 SET RS=""
- IF $DATA(^RMPF(791813,RMPFSTAN,2))
- SET R=$PIECE(^(2),U,2)
- SET RS=$SELECT(R'="":"("_R_")",1:"")
- +5 SET @("RMPF"_TY_"(1)")=$SELECT($PIECE(S0,U,4)'="":$PIECE(S0,U,4),1:"VA MEDICAL CENTER")_" "_RS
- SET S1=$SELECT($DATA(^DIC(4,ST,1)):^(1),1:"")
- +6 FOR I=1:1:2
- SET X=$PIECE(S1,U,I)
- IF X'=""
- SET CT=CT+1
- SET @("RMPF"_TY_"("_CT_")")=X
- +7 SET C=$PIECE(S1,U,3)
- SET Z=$PIECE(S1,U,4)
- SET CT=CT+1
- +8 SET @("RMPF"_TY_"("_CT_")")=$EXTRACT(C,1,21)_", "_S_" "_Z
- +9 KILL C,CT,Z,S,X,S0,S1,I,Z
- QUIT
- MOD DO ARRAY^RMPFDT2
- SET RMPFY=0
- D1 SET RMPFY=$ORDER(RMPFO(RMPFY))
- if RMPFY=""
- GOTO END1
- if '$DATA(^RMPF(791810,RMPFX,101,RMPFY,0))
- GOTO D1
- SET S1=^(0)
- SET RMPFIT=$PIECE(S1,U,1)
- +1 if 'RMPFIT
- GOTO D1
- if '$DATA(^RMPF(791811,RMPFIT,0))
- GOTO D1
- SET S2=^(0)
- SET RMPFITP=$PIECE(S2,U,1)
- SET RMPFMAK=$PIECE(S2,U,2)
- +2 IF RMPFITP="NON-CONTRACT"
- IF $DATA(^RMPF(791810,RMPFX,101,RMPFY,2))
- SET RMPFITP=$PIECE(^(2),U,2)
- SET RMPFMAK=$PIECE(^(2),U,1)
- +3 SET RMPFNSN=$PIECE($PIECE(S2,U,5),"-",3,4)
- +4 SET RMPFSN=$PIECE(S1,U,5)
- SET RMPFBAT=$PIECE(S1,U,2)
- IF RMPFBAT
- IF $DATA(^RMPF(791811.3,RMPFBAT,0))
- SET RMPFBAT=$PIECE(^(0),U,1)
- +5 SET RMPFBAT2=""
- IF $DATA(^RMPF(791810,RMPFX,101,RMPFY,2))
- SET RMPFBAT2=$PIECE(^(2),U,3)
- IF RMPFBAT2
- IF $DATA(^RMPF(791811.3,RMPFBAT2,0))
- SET RMPFBAT2=$PIECE(^(0),U,1)
- +6 SET RMPFIDP=""
- SET Y=$PIECE(S1,U,8)
- +7 IF Y
- DO DD^%DT
- SET RMPFIDP=Y
- +8 SET RMPFREP=$SELECT($DATA(^RMPF(791810,RMPFX,11)):$PIECE(^(11),U,3),1:"")
- MODEL WRITE !,"6515-01-",RMPFNSN
- +1 WRITE ?16,"|",?17,$EXTRACT(RMPFMAK,1,10)
- +2 WRITE ?27,"|",?28,$EXTRACT(RMPFITP,1,16)
- +3 WRITE ?44,"|",?46,$EXTRACT(RMPFSN,1,10)
- +4 WRITE ?57,"|",?59,$EXTRACT(RMPFBAT,1,7)
- +5 WRITE ?67,"|"
- SET (X,CT)=0
- +6 FOR I=1:1
- SET X=$ORDER(^RMPF(791810,RMPFX,101,RMPFY,101,X))
- if 'X
- QUIT
- Begin DoDot:1
- +7 if '$DATA(^RMPF(791810,RMPFX,101,RMPFY,101,X,0))
- QUIT
- SET SN=$PIECE(^(0),U,1)
- +8 IF 'CT
- WRITE ?69,$EXTRACT(SN,1,11)
- SET CT=CT+1
- QUIT
- +9 WRITE !,?16,"|",?27,"|",?44,"|",?57,"|"
- +10 IF $DATA(RMPFBAT2)
- IF RMPFBAT2'=""
- WRITE ?59,$EXTRACT(RMPFBAT2,1,7)
- KILL RMPFBAT2
- +11 WRITE ?67,"|",?69,$EXTRACT(SN,1,11)
- +12 QUIT
- End DoDot:1
- +13 IF $DATA(RMPFBAT2)
- IF RMPFBAT2'=""
- WRITE !?16,"|",?27,"|",?44,"|",?57,"|",?59,$EXTRACT(RMPFBAT2,1,7),?67,"|"
- +14 DO LINE^RMPFQP3
- +15 GOTO D1
- END1 KILL RMPFY,RMPFIT,RMPFITP,RMPFMAK,RMPFNSN,RMPFSN,RMPFBAT
- +1 KILL RMPFIDP,RMPFRSN,CT,SN,S1,I,S2,X
- QUIT
