RMPFPOSU ;DDC/KAW-CONTINUATION OF RMPFPOST [ 06/16/95 3:06 PM ]
;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
ORDER S X=$O(^DIC(9.4,"B","REMOTE ORDER/ENTRY SYSTEM",0)) G EXIT:'X
W !!,"Updating old orders" K RMPF
F I="DEAF/U","DEAF/B" S RMPF($P(I,"/",2))=$O(^RMPR(662,"B",I,0))
S RMPFX=0
O1 S RMPFX=$O(^RMPF(791810,RMPFX))
G EXIT:'RMPFX,O1:'$D(^RMPF(791810,RMPFX,0)) S S0=^(0) W "."
S RMPFST=$P(S0,U,3),RMPFSD=$P(S0,U,6)
S:RMPFST="" RMPFST=1
I RMPFSD="" S RMPFSD=$P(S0,U,1),DIE="^RMPF(791810,",DA=RMPFX,DR=".06////"_RMPFSD D ^DIE
S ^RMPF(791810,"AD",9999999.9999-RMPFSD,RMPFX)=""
S RMPFTYP=$P(S0,U,2),RMPFTP=""
I RMPFTYP=2,RMPFST=5!(RMPFST=4),$P(S0,U,15)="" S DIE="^RMPF(791810,",DA=RMPFX,DR=".02///CUSTOM HEARING AID ISSUE" D ^DIE S RMPFTYP=$P(^RMPF(791810,RMPFX,0),U,2) I RMPFST=5 D
.S RMPFST=17,DA=RMPFX,DIE="^RMPF(791810,",DR=".03////"_RMPFST D ^DIE
I "51"[RMPFTYP S X=$G(^RMPF(791810,RMPFX,10)) I $P(X,U,8)="" S Y=$P(X,U,4) S:Y="" Y=RMPFSD S $P(^RMPF(791810,RMPFX,10),U,8)=Y ;;Add Audiological Assessment Date
I RMPFTYP,$D(^RMPF(791810.1,RMPFTYP,0)) S RMPFTP=$P(^(0),U,3)
S:$P(^RMPF(791810,RMPFX,0),U,15)="" $P(^RMPF(791810,RMPFX,0),U,15)=1 ;;Add menu pointer
S:$P($G(^RMPF(791810,RMPFX,10)),U,5)="" $P(^RMPF(791810,RMPFX,10),U,5)="R" ;;Add delivery category
I RMPFTP="P" D
.S RMPFDC=$P($G(^RMPF(791810,RMPFX,2)),U,1)
.I RMPFDC="" S RMPFDC="B"
.I 'RMPFDC S RMPFDC=$G(RMPF(RMPFDC)) S:RMPFDC="" RMPFDC=44
.S $P(^RMPF(791810,RMPFX,2),U,1)=RMPFDC
.S DFN=$P(^RMPF(791810,RMPFX,0),U,4) D ELIGBL:DFN'=""
S RMPFY=0
O2 S RMPFY=$O(^RMPF(791810,RMPFX,101,RMPFY)) G O1:'RMPFY S S1=$G(^(RMPFY,0))
I $P(S1,U,17)="" S $P(^RMPF(791810,RMPFX,101,RMPFY,0),U,17)=RMPFSD
I $P(S1,U,18)="" S $P(^RMPF(791810,RMPFX,101,RMPFY,0),U,18)=RMPFST
I $P(S1,U,19)="" S LA=$S(RMPFTYP=2&(RMPFST=8):"I",1:"O"),$P(^RMPF(791810,RMPFX,101,RMPFY,0),U,19)=LA
I $P(S1,U,20)="" S $P(^RMPF(791810,RMPFX,101,RMPFY,0),U,20)=1
G O2
EXIT W !!,"POST-INIT COMPLETE"
K X,DA,DIE,DR,D0,DG,DQ,DI,DIC,D,AB,XY,RMPFX,RMPFST,RMPFTYP,RMPFTP
K RMPFDC,RMPF,SD,DD,DFN,IY,LA,P,RMPFF,RMPFL,RMPFSD,RMPFTE,RMPFY,S0,S1
K ST,VAEL,VAMB,VAERR,VASV,YY
END Q
ELIGBL D DISABLE^RMPFUTL,ELIG^VADPT,SVC^VADPT,MB^VADPT S X=0,RMPFTE=""
E1 S X=$O(^DPT(DFN,.372,X)) G ELGE:RMPFTE'="",ELG1:'X I $D(^(X,0)) S ST=^(0),D=$P(ST,U,1) I D,$D(RMPFL(D)) S DD=$P(^DIC(31,D,0),U,1),P=$P(ST,U,2),RMPFTE=1
G E1
ELG1 D SUB S:RMPFTE="" RMPFTE=1
ELGE S $P(^RMPF(791810,RMPFX,2),U,2)=RMPFTE Q
SUB ;; input: DFN,C,VAEL,VASV,VAMB
;;output: RMPFF
Q:'$D(DFN) Q:'DFN S C=0
S ST="2;3;4;5;6;7;16;9"
K RMPF F IY=1:1:7 S XX=$P($T(@IY),";",3) S RMPF(XX)=$P(ST,";",IY)
F IX=1:1:7 Q:RMPFTE'="" S XX=$P($T(@IX),";",3),ZZ=$P($T(@IX),";",4),YY=$O(^DIC(8,"B",XX,0)) X:ZZ'="" ZZ I YY,$P(VAEL(1),U,1)=YY!($D(VAEL(1,YY))) S RMPFTE=RMPF(XX) Q
K IX,XX,ZZ,Y,C,I,X,Y Q
1 ;;SERVICE CONNECTED 50% to 100%
2 ;;PRISONER OF WAR;I VASV(4) S RMPFTE=3,YY=""
3 ;;MEXICAN BORDER WAR
4 ;;WORLD WAR I;I $P(VAEL(2),U,2)="WORLD WAR I" S RMPFTE=5,YY=""
5 ;;AID & ATTENDANCE;I VAMB(1)'=0 S RMPFTE=6,YY=""
6 ;;HOUSEBOUND;I VAMB(2)'=0 S RMPFTE=7,YY=""
7 ;;ALLIED VETERAN;D ALLIED^RMPFDD2 I RMPFTE["ALLIED VETERAN" S RMPFTE=8
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFPOSU 3191 printed Sep 23, 2025@20:13:01 Page 2
RMPFPOSU ;DDC/KAW-CONTINUATION OF RMPFPOST [ 06/16/95 3:06 PM ]
+1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
ORDER SET X=$ORDER(^DIC(9.4,"B","REMOTE ORDER/ENTRY SYSTEM",0))
if 'X
GOTO EXIT
+1 WRITE !!,"Updating old orders"
KILL RMPF
+2 FOR I="DEAF/U","DEAF/B"
SET RMPF($PIECE(I,"/",2))=$ORDER(^RMPR(662,"B",I,0))
+3 SET RMPFX=0
O1 SET RMPFX=$ORDER(^RMPF(791810,RMPFX))
+1 if 'RMPFX
GOTO EXIT
if '$DATA(^RMPF(791810,RMPFX,0))
GOTO O1
SET S0=^(0)
WRITE "."
+2 SET RMPFST=$PIECE(S0,U,3)
SET RMPFSD=$PIECE(S0,U,6)
+3 if RMPFST=""
SET RMPFST=1
+4 IF RMPFSD=""
SET RMPFSD=$PIECE(S0,U,1)
SET DIE="^RMPF(791810,"
SET DA=RMPFX
SET DR=".06////"_RMPFSD
DO ^DIE
+5 SET ^RMPF(791810,"AD",9999999.9999-RMPFSD,RMPFX)=""
+6 SET RMPFTYP=$PIECE(S0,U,2)
SET RMPFTP=""
+7 IF RMPFTYP=2
IF RMPFST=5!(RMPFST=4)
IF $PIECE(S0,U,15)=""
SET DIE="^RMPF(791810,"
SET DA=RMPFX
SET DR=".02///CUSTOM HEARING AID ISSUE"
DO ^DIE
SET RMPFTYP=$PIECE(^RMPF(791810,RMPFX,0),U,2)
IF RMPFST=5
Begin DoDot:1
+8 SET RMPFST=17
SET DA=RMPFX
SET DIE="^RMPF(791810,"
SET DR=".03////"_RMPFST
DO ^DIE
End DoDot:1
+9 ;;Add Audiological Assessment Date
IF "51"[RMPFTYP
SET X=$GET(^RMPF(791810,RMPFX,10))
IF $PIECE(X,U,8)=""
SET Y=$PIECE(X,U,4)
if Y=""
SET Y=RMPFSD
SET $PIECE(^RMPF(791810,RMPFX,10),U,8)=Y
+10 IF RMPFTYP
IF $DATA(^RMPF(791810.1,RMPFTYP,0))
SET RMPFTP=$PIECE(^(0),U,3)
+11 ;;Add menu pointer
if $PIECE(^RMPF(791810,RMPFX,0),U,15)=""
SET $PIECE(^RMPF(791810,RMPFX,0),U,15)=1
+12 ;;Add delivery category
if $PIECE($GET(^RMPF(791810,RMPFX,10)),U,5)=""
SET $PIECE(^RMPF(791810,RMPFX,10),U,5)="R"
+13 IF RMPFTP="P"
Begin DoDot:1
+14 SET RMPFDC=$PIECE($GET(^RMPF(791810,RMPFX,2)),U,1)
+15 IF RMPFDC=""
SET RMPFDC="B"
+16 IF 'RMPFDC
SET RMPFDC=$GET(RMPF(RMPFDC))
if RMPFDC=""
SET RMPFDC=44
+17 SET $PIECE(^RMPF(791810,RMPFX,2),U,1)=RMPFDC
+18 SET DFN=$PIECE(^RMPF(791810,RMPFX,0),U,4)
if DFN'=""
DO ELIGBL
End DoDot:1
+19 SET RMPFY=0
O2 SET RMPFY=$ORDER(^RMPF(791810,RMPFX,101,RMPFY))
if 'RMPFY
GOTO O1
SET S1=$GET(^(RMPFY,0))
+1 IF $PIECE(S1,U,17)=""
SET $PIECE(^RMPF(791810,RMPFX,101,RMPFY,0),U,17)=RMPFSD
+2 IF $PIECE(S1,U,18)=""
SET $PIECE(^RMPF(791810,RMPFX,101,RMPFY,0),U,18)=RMPFST
+3 IF $PIECE(S1,U,19)=""
SET LA=$SELECT(RMPFTYP=2&(RMPFST=8):"I",1:"O")
SET $PIECE(^RMPF(791810,RMPFX,101,RMPFY,0),U,19)=LA
+4 IF $PIECE(S1,U,20)=""
SET $PIECE(^RMPF(791810,RMPFX,101,RMPFY,0),U,20)=1
+5 GOTO O2
EXIT WRITE !!,"POST-INIT COMPLETE"
+1 KILL X,DA,DIE,DR,D0,DG,DQ,DI,DIC,D,AB,XY,RMPFX,RMPFST,RMPFTYP,RMPFTP
+2 KILL RMPFDC,RMPF,SD,DD,DFN,IY,LA,P,RMPFF,RMPFL,RMPFSD,RMPFTE,RMPFY,S0,S1
+3 KILL ST,VAEL,VAMB,VAERR,VASV,YY
END QUIT
ELIGBL DO DISABLE^RMPFUTL
DO ELIG^VADPT
DO SVC^VADPT
DO MB^VADPT
SET X=0
SET RMPFTE=""
E1 SET X=$ORDER(^DPT(DFN,.372,X))
if RMPFTE'=""
GOTO ELGE
if 'X
GOTO ELG1
IF $DATA(^(X,0))
SET ST=^(0)
SET D=$PIECE(ST,U,1)
IF D
IF $DATA(RMPFL(D))
SET DD=$PIECE(^DIC(31,D,0),U,1)
SET P=$PIECE(ST,U,2)
SET RMPFTE=1
+1 GOTO E1
ELG1 DO SUB
if RMPFTE=""
SET RMPFTE=1
ELGE SET $PIECE(^RMPF(791810,RMPFX,2),U,2)=RMPFTE
QUIT
SUB ;; input: DFN,C,VAEL,VASV,VAMB
+1 ;;output: RMPFF
+2 if '$DATA(DFN)
QUIT
if 'DFN
QUIT
SET C=0
+3 SET ST="2;3;4;5;6;7;16;9"
+4 KILL RMPF
FOR IY=1:1:7
SET XX=$PIECE($TEXT(@IY),";",3)
SET RMPF(XX)=$PIECE(ST,";",IY)
+5 FOR IX=1:1:7
if RMPFTE'=""
QUIT
SET XX=$PIECE($TEXT(@IX),";",3)
SET ZZ=$PIECE($TEXT(@IX),";",4)
SET YY=$ORDER(^DIC(8,"B",XX,0))
if ZZ'=""
XECUTE ZZ
IF YY
IF $PIECE(VAEL(1),U,1)=YY!($DATA(VAEL(1,YY)))
SET RMPFTE=RMPF(XX)
QUIT
+6 KILL IX,XX,ZZ,Y,C,I,X,Y
QUIT
1 ;;SERVICE CONNECTED 50% to 100%
2 ;;PRISONER OF WAR;I VASV(4) S RMPFTE=3,YY=""
3 ;;MEXICAN BORDER WAR
4 ;;WORLD WAR I;I $P(VAEL(2),U,2)="WORLD WAR I" S RMPFTE=5,YY=""
5 ;;AID & ATTENDANCE;I VAMB(1)'=0 S RMPFTE=6,YY=""
6 ;;HOUSEBOUND;I VAMB(2)'=0 S RMPFTE=7,YY=""
7 ;;ALLIED VETERAN;D ALLIED^RMPFDD2 I RMPFTE["ALLIED VETERAN" S RMPFTE=8
