- RMPOPAT ;HINES CIO/RVD-DISPLAY 2319 FIRST PAGE READ ONLY ;7/5/02
- ;;3.0;PROSTHETICS;**70**;Feb 09, 1996
- ;
- ; RVD 7/5/02 - patch # 70 - this routine is a copy of RMPRPAT for
- ; Read Only 2319, without comments and
- ; disability codes.
- ;
- ASK ;Set common variables
- Q:$G(RMPRDFN)<1
- D HOME^%ZIS S DFN=RMPRDFN,RMPRBACK=1
- D ADD^VADPT,OAD^VADPT,DEM^VADPT,ELIG^VADPT
- S RMPRNAM=$P(VADM(1),U),RMPRSSN=$P(VADM(2),U)
- S RMPRDOB=$P(VADM(3),U),RMPRSSNE=VA("PID")
- W @IOF
- S %X="^RMPR(665,"_RMPRDFN_",",%Y="R5(" D %XY^%RCR S RMPRCNUM=VAEL(7)
- ASK1 ;CALL ROUTINE TO DISPLAY SCREEN SELECTI0N
- Q:$G(RMPRDFN)'>0 S DFN=RMPRDFN
- I '$D(VAEL(7)) D ELIG^VADPT
- I '$D(VAPA(1)) D ADD^VADPT
- I '$D(VADM(1)) D DEM^VADPT
- I '$D(VAOA(1)) D OAD^VADPT
- ;I $D(^RMPR(665,RMPRDFN,8,0)) W !,"*Comments on file"
- ;I '$D(^RMPR(665,RMPRDFN,1,0)) W $C(7),!!,"*No Disability Code on File!"
- ;I $D(^RMPR(665,RMPRDFN,1,0)),'$O(^(0)) W $C(7),!!,"*No Disability Code on File!"
- ;D DISP^RMPRPAT5 K ANS
- ;K RMPRQ,RMPRQUES,DIR
- D ASK1^RMPOPAT1 K ANS
- D ^DIR
- K DIR
- I Y["^" G EXIT
- I Y="",'$D(RMPR1APN) G EXIT
- I (Y="I")!(Y="H") S ANS=Y G QUE
- ;RMPR1APN is set in the entry action to menu RMPR PRINT 2319
- ;and killed in the exit action. We do not want to prompt
- ;patient name while creating records, only in display
- ;options
- ;prompt to select a new patient
- I Y="",$D(RMPR1APN) S RMPR2APN=RMPRDFN D GETPAT^RMPRUTIL
- I '$D(RMPRDFN) S RMPRDFN=RMPR2APN G EXIT
- I $D(RMPR2APN) K RMPR2APN D ASK1
- Q
- ASK2 ;ASK TO CONTINUE AFTER SCREEN DISPLAY
- G ASK1
- HELP W !,"You may only enter screen (I-H),`^`, or `return`" G ASK2
- Q
- STAR ;DISPLAY ADDRESS INFO
- Q:$G(DFN)'>0
- S RMPRBACK=1
- I '$D(VADM(1))!('$D(VAOA(8))!('$D(VAPA(8))!('$D(VAEL(7))))) N VAHOW D DEM^VADPT,ADD^VADPT,OAD^VADPT
- W:$E(IOST)["C" @IOF
- W !,$E(RMPRNAM,1,20),?23,"SSN: ",$P(VADM(2),U,2),?42
- W "DOB: ",$P(VADM(3),U,2),?61,"CLAIM# ",VAEL(7) ;RMPRCNUM
- STARD W !!,"Phone: ",VAPA(8),?40,"Phone: ",VAOA(8)
- W !,"Current Address:",?40,"Primary Next of Kin Address:"
- W !,VAPA(1),?40,VAOA(1)
- I VAPA(2)=""&(VAPA(3)="") W:VAPA(4)'="" !,VAPA(4)_", "_$P(VAPA(5),U,2)_" "_VAPA(6) W:VAOA(4)'="" ?40,VAOA(4)_", "_$P(VAOA(5),U,2)_" "_VAOA(6) W:VAOA(10)'="" !,?40,"Relationship: ",VAOA(10) G END
- I VAPA(2)'=""&(VAPA(3)="") W !,VAPA(2) W:VAOA(4)'="" ?40,VAOA(4)_", "_$P(VAOA(5),U,2)_" "_VAOA(6) W:VAPA(4)'="" !,VAPA(4)_", "_$P(VAPA(5),U,2)_" "_VAPA(6) W:VAOA(10)'="" ?40,"Relationship: ",VAOA(10) G END
- I VAPA(2)'=""&(VAPA(3))'="" W !,VAPA(2) W:VAOA(4)'="" ?40,VAOA(4)_", ",$P(VAOA(5),U,2)_" "_VAOA(6),!,VAPA(3) W:VAOA(10)'="" ?40,"Relationship: ",VAOA(10)
- I W:VAPA(4)'="" !,VAPA(4)_", "_$P(VAPA(5),U,2)_" "_VAPA(6)
- END D ELIG^VADPT
- W !!,"Patient Type: ",$P(VAEL(6),U,2),?40
- W "Period of Service: ",$P(VAEL(2),U,2)
- W !,"Primary Eligibility Code:",?40
- W "Status: ",$P(VAEL(9),U,2),!,$P(VAEL(1),U,2)
- W ?40,"Eligibility Status: ",$E($P(VAEL(8),U,2),1,19)
- D MB^VADPT
- W !!,"Receiving A&A Benefits? "
- W:VAMB(1)=0 "NO" W:$P(VAMB(1),U,1)=1 $P(VAMB(1),U,2)
- W ?40,"Receiving Housebound Benefits? "
- W:VAMB(2)=0 "NO" W:$P(VAMB(2),U,1)=1 $P(VAMB(2),U,2)
- W !,"Receiving Social Security? "
- W:VAMB(3)=0 "NO" W:$P(VAMB(3),U,1)=1 $P(VAMB(3),U,2)
- W ?40,"Receiving VA Pension? " W:VAMB(4)=0 "NO"
- W:$P(VAMB(4),U,1)=1 $P(VAMB(4),U,2)
- W !,"Receiving Military Retirement? "
- W:VAMB(5)=0 "NO" W:$P(VAMB(5),U,1)=1 $P(VAMB(5),U,2)
- W ?40,"Receiving VA Disability? " W:VAMB(7)=0 "NO"
- W:$P(VAMB(7),U,1)=1 $P(VAMB(7),U,2)
- S (RO,FG)=0 I '$D(^RMPR(665,RMPRDFN,1)) W !,"No Prosthetic Disability Codes entered for this Patient." S RO=1
- I RO=0 F W:'FG !,"Prosthetic Disability Code(s):" S RO=$O(^RMPR(665,RMPRDFN,1,RO)) Q:RO'>0 S RR=^(RO,0) S:$P(RR,U,10) FG=1 I '$P(RR,U,10) W " ",$P(^RMPR(662,+RR,0),U,1),"-",$S($P(RR,U,3)=1:"SC",$P(RR,U,3)=2:"NSC",1:"") S FG=1
- K RMNOQUIT G:$D(RMPREND1) EXIT
- D SVC^VADPT W !!,"*POW? ",$S(VASV(4)=1:"YES",1:"NO")
- G:$D(RMPRBACK) QUES
- W @IOF G ASK1
- WRI I $Y>(IOSL-7),'$D(RMPRQUES) D QUEST1 G:$D(RMPREND1) ASK1
- QUES ;ASK WHAT PAGE OF A PATIENT'S 10-2319
- K RMPRFLG,RMPRL F I=0:0 Q:$Y>21 W !
- QUES1 R !,"Enter return to continue or `^` to exit: ",ANS:DTIME
- G:'$T EXIT
- I ANS="" G ASK1
- I $G(ANS)="" G EXIT
- I "^"[ANS G ASK1
- E W $C(7),!,"You must enter an `^` to exit!" G QUES1
- QUE ;W:ANS=5 @IOF
- G EXIT:"^"[ANS
- I ANS="I" G ^RMPOPAT2
- I ANS="H" G 2319^RMPOBIL6
- W !!,$C(7) G QUES
- Q
- EXIT ;EXIT FOR DISPLAY OF A PATIENT'S 10-2319
- ;must always exit through this point
- ;I '$D(^RMPR(665,RMPRDFN,1,0)) D DIS^RMPRPAT5
- ;I $D(^RMPR(665,RMPRDFN,1,0)),'$O(^(0)) D DIS^RMPRPAT5
- I $D(^RMPR(665,RMPRDFN,1,0)),$O(^(0)) K RMPRKILL
- ;D NPC^RMPRPAT5
- K RMPRCOMB,Y,DIE,DIC,RMPRCCO,DIR,VASV,VAMB,VAEL,VADM,VAPA,FG,VAOA,TYPE,RMPROBL,RC,AMIS,CST,DATE,DEL,RFLG,QTY,REM,SN,STA,RR,RO,I,J,RMPRCNUM,RMPRFG,TRANS,TRANS1,RK,FLG,RA,RI,RT,RTCH,LC,MC,RMPRDT,RMPRJOB,RMPRWO
- K RMPR2APN,RMPRQ,RR5,R5,DFN,FL,PAGE,AN,FRM,VEN,RZ,%X,%Y,VA,VAERR,TLC,TMC,R660,RCK,RJ,RDA,RL,RTC,RTCD,RTHD,RTR,RW,RWP,RMPRQUES,RMPREND1 D KVAR^VADPT
- K:'$D(RMPRF)!($G(RMPRBACK)<1) RMPRDOB,RMPRDFN,RMPRNAM,RMPRSSN,RMPRBACK
- K RMPOPFLG,RMPR1APN
- Q
- QUEST1 S RMPRQUES=1
- N DIR S DIR(0)="E" W !! D ^DIR W @IOF
- I $D(DTOUT)!($D(DUOUT)) S RMPREND1=1 G ASK1
- W ! Q
- QUEST2 ;PUT MAS DISABILITY CODES ON NEXT PAGE IF THEY WILL NOT ALL FIT ON THIS
- ;PAGE
- N DIR S DIR(0)="E" W !! D ^DIR W @IOF S RMNOQUIT=1
- I $D(DTOUT)!($D(DUOUT)) S RMNOQUIT=0
- W @IOF
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPOPAT 5488 printed Jan 18, 2025@03:32:22 Page 2
- RMPOPAT ;HINES CIO/RVD-DISPLAY 2319 FIRST PAGE READ ONLY ;7/5/02
- +1 ;;3.0;PROSTHETICS;**70**;Feb 09, 1996
- +2 ;
- +3 ; RVD 7/5/02 - patch # 70 - this routine is a copy of RMPRPAT for
- +4 ; Read Only 2319, without comments and
- +5 ; disability codes.
- +6 ;
- ASK ;Set common variables
- +1 if $GET(RMPRDFN)<1
- QUIT
- +2 DO HOME^%ZIS
- SET DFN=RMPRDFN
- SET RMPRBACK=1
- +3 DO ADD^VADPT
- DO OAD^VADPT
- DO DEM^VADPT
- DO ELIG^VADPT
- +4 SET RMPRNAM=$PIECE(VADM(1),U)
- SET RMPRSSN=$PIECE(VADM(2),U)
- +5 SET RMPRDOB=$PIECE(VADM(3),U)
- SET RMPRSSNE=VA("PID")
- +6 WRITE @IOF
- +7 SET %X="^RMPR(665,"_RMPRDFN_","
- SET %Y="R5("
- DO %XY^%RCR
- SET RMPRCNUM=VAEL(7)
- ASK1 ;CALL ROUTINE TO DISPLAY SCREEN SELECTI0N
- +1 if $GET(RMPRDFN)'>0
- QUIT
- SET DFN=RMPRDFN
- +2 IF '$DATA(VAEL(7))
- DO ELIG^VADPT
- +3 IF '$DATA(VAPA(1))
- DO ADD^VADPT
- +4 IF '$DATA(VADM(1))
- DO DEM^VADPT
- +5 IF '$DATA(VAOA(1))
- DO OAD^VADPT
- +6 ;I $D(^RMPR(665,RMPRDFN,8,0)) W !,"*Comments on file"
- +7 ;I '$D(^RMPR(665,RMPRDFN,1,0)) W $C(7),!!,"*No Disability Code on File!"
- +8 ;I $D(^RMPR(665,RMPRDFN,1,0)),'$O(^(0)) W $C(7),!!,"*No Disability Code on File!"
- +9 ;D DISP^RMPRPAT5 K ANS
- +10 ;K RMPRQ,RMPRQUES,DIR
- +11 DO ASK1^RMPOPAT1
- KILL ANS
- +12 DO ^DIR
- +13 KILL DIR
- +14 IF Y["^"
- GOTO EXIT
- +15 IF Y=""
- IF '$DATA(RMPR1APN)
- GOTO EXIT
- +16 IF (Y="I")!(Y="H")
- SET ANS=Y
- GOTO QUE
- +17 ;RMPR1APN is set in the entry action to menu RMPR PRINT 2319
- +18 ;and killed in the exit action. We do not want to prompt
- +19 ;patient name while creating records, only in display
- +20 ;options
- +21 ;prompt to select a new patient
- +22 IF Y=""
- IF $DATA(RMPR1APN)
- SET RMPR2APN=RMPRDFN
- DO GETPAT^RMPRUTIL
- +23 IF '$DATA(RMPRDFN)
- SET RMPRDFN=RMPR2APN
- GOTO EXIT
- +24 IF $DATA(RMPR2APN)
- KILL RMPR2APN
- DO ASK1
- +25 QUIT
- ASK2 ;ASK TO CONTINUE AFTER SCREEN DISPLAY
- +1 GOTO ASK1
- HELP WRITE !,"You may only enter screen (I-H),`^`, or `return`"
- GOTO ASK2
- +1 QUIT
- STAR ;DISPLAY ADDRESS INFO
- +1 if $GET(DFN)'>0
- QUIT
- +2 SET RMPRBACK=1
- +3 IF '$DATA(VADM(1))!('$DATA(VAOA(8))!('$DATA(VAPA(8))!('$DATA(VAEL(7)))))
- NEW VAHOW
- DO DEM^VADPT
- DO ADD^VADPT
- DO OAD^VADPT
- +4 if $EXTRACT(IOST)["C"
- WRITE @IOF
- +5 WRITE !,$EXTRACT(RMPRNAM,1,20),?23,"SSN: ",$PIECE(VADM(2),U,2),?42
- +6 ;RMPRCNUM
- WRITE "DOB: ",$PIECE(VADM(3),U,2),?61,"CLAIM# ",VAEL(7)
- STARD WRITE !!,"Phone: ",VAPA(8),?40,"Phone: ",VAOA(8)
- +1 WRITE !,"Current Address:",?40,"Primary Next of Kin Address:"
- +2 WRITE !,VAPA(1),?40,VAOA(1)
- +3 IF VAPA(2)=""&(VAPA(3)="")
- if VAPA(4)'=""
- WRITE !,VAPA(4)_", "_$PIECE(VAPA(5),U,2)_" "_VAPA(6)
- if VAOA(4)'=""
- WRITE ?40,VAOA(4)_", "_$PIECE(VAOA(5),U,2)_" "_VAOA(6)
- if VAOA(10)'=""
- WRITE !,?40,"Relationship: ",VAOA(10)
- GOTO END
- +4 IF VAPA(2)'=""&(VAPA(3)="")
- WRITE !,VAPA(2)
- if VAOA(4)'=""
- WRITE ?40,VAOA(4)_", "_$PIECE(VAOA(5),U,2)_" "_VAOA(6)
- if VAPA(4)'=""
- WRITE !,VAPA(4)_", "_$PIECE(VAPA(5),U,2)_" "_VAPA(6)
- if VAOA(10)'=""
- WRITE ?40,"Relationship: ",VAOA(10)
- GOTO END
- +5 IF VAPA(2)'=""&(VAPA(3))'=""
- WRITE !,VAPA(2)
- if VAOA(4)'=""
- WRITE ?40,VAOA(4)_", ",$PIECE(VAOA(5),U,2)_" "_VAOA(6),!,VAPA(3)
- if VAOA(10)'=""
- WRITE ?40,"Relationship: ",VAOA(10)
- +6 IF $TEST
- if VAPA(4)'=""
- WRITE !,VAPA(4)_", "_$PIECE(VAPA(5),U,2)_" "_VAPA(6)
- END DO ELIG^VADPT
- +1 WRITE !!,"Patient Type: ",$PIECE(VAEL(6),U,2),?40
- +2 WRITE "Period of Service: ",$PIECE(VAEL(2),U,2)
- +3 WRITE !,"Primary Eligibility Code:",?40
- +4 WRITE "Status: ",$PIECE(VAEL(9),U,2),!,$PIECE(VAEL(1),U,2)
- +5 WRITE ?40,"Eligibility Status: ",$EXTRACT($PIECE(VAEL(8),U,2),1,19)
- +6 DO MB^VADPT
- +7 WRITE !!,"Receiving A&A Benefits? "
- +8 if VAMB(1)=0
- WRITE "NO"
- if $PIECE(VAMB(1),U,1)=1
- WRITE $PIECE(VAMB(1),U,2)
- +9 WRITE ?40,"Receiving Housebound Benefits? "
- +10 if VAMB(2)=0
- WRITE "NO"
- if $PIECE(VAMB(2),U,1)=1
- WRITE $PIECE(VAMB(2),U,2)
- +11 WRITE !,"Receiving Social Security? "
- +12 if VAMB(3)=0
- WRITE "NO"
- if $PIECE(VAMB(3),U,1)=1
- WRITE $PIECE(VAMB(3),U,2)
- +13 WRITE ?40,"Receiving VA Pension? "
- if VAMB(4)=0
- WRITE "NO"
- +14 if $PIECE(VAMB(4),U,1)=1
- WRITE $PIECE(VAMB(4),U,2)
- +15 WRITE !,"Receiving Military Retirement? "
- +16 if VAMB(5)=0
- WRITE "NO"
- if $PIECE(VAMB(5),U,1)=1
- WRITE $PIECE(VAMB(5),U,2)
- +17 WRITE ?40,"Receiving VA Disability? "
- if VAMB(7)=0
- WRITE "NO"
- +18 if $PIECE(VAMB(7),U,1)=1
- WRITE $PIECE(VAMB(7),U,2)
- +19 SET (RO,FG)=0
- IF '$DATA(^RMPR(665,RMPRDFN,1))
- WRITE !,"No Prosthetic Disability Codes entered for this Patient."
- SET RO=1
- +20 IF RO=0
- FOR
- if 'FG
- WRITE !,"Prosthetic Disability Code(s):"
- SET RO=$ORDER(^RMPR(665,RMPRDFN,1,RO))
- if RO'>0
- QUIT
- SET RR=^(RO,0)
- if $PIECE(RR,U,10)
- SET FG=1
- IF '$PIECE(RR,U,10)
- WRITE " ",$PIECE(^RMPR(662,+RR,0),U,1),"-",$SELECT($PIECE(RR,U,3)=1:"SC",$PIECE(RR,U,3)=2:"NSC",1:"")
- SET FG=1
- +21 KILL RMNOQUIT
- if $DATA(RMPREND1)
- GOTO EXIT
- +22 DO SVC^VADPT
- WRITE !!,"*POW? ",$SELECT(VASV(4)=1:"YES",1:"NO")
- +23 if $DATA(RMPRBACK)
- GOTO QUES
- +24 WRITE @IOF
- GOTO ASK1
- WRI IF $Y>(IOSL-7)
- IF '$DATA(RMPRQUES)
- DO QUEST1
- if $DATA(RMPREND1)
- GOTO ASK1
- QUES ;ASK WHAT PAGE OF A PATIENT'S 10-2319
- +1 KILL RMPRFLG,RMPRL
- FOR I=0:0
- if $Y>21
- QUIT
- WRITE !
- QUES1 READ !,"Enter return to continue or `^` to exit: ",ANS:DTIME
- +1 if '$TEST
- GOTO EXIT
- +2 IF ANS=""
- GOTO ASK1
- +3 IF $GET(ANS)=""
- GOTO EXIT
- +4 IF "^"[ANS
- GOTO ASK1
- +5 IF '$TEST
- WRITE $CHAR(7),!,"You must enter an `^` to exit!"
- GOTO QUES1
- QUE ;W:ANS=5 @IOF
- +1 if "^"[ANS
- GOTO EXIT
- +2 IF ANS="I"
- GOTO ^RMPOPAT2
- +3 IF ANS="H"
- GOTO 2319^RMPOBIL6
- +4 WRITE !!,$CHAR(7)
- GOTO QUES
- +5 QUIT
- EXIT ;EXIT FOR DISPLAY OF A PATIENT'S 10-2319
- +1 ;must always exit through this point
- +2 ;I '$D(^RMPR(665,RMPRDFN,1,0)) D DIS^RMPRPAT5
- +3 ;I $D(^RMPR(665,RMPRDFN,1,0)),'$O(^(0)) D DIS^RMPRPAT5
- +4 IF $DATA(^RMPR(665,RMPRDFN,1,0))
- IF $ORDER(^(0))
- KILL RMPRKILL
- +5 ;D NPC^RMPRPAT5
- +6 KILL RMPRCOMB,Y,DIE,DIC,RMPRCCO,DIR,VASV,VAMB,VAEL,VADM,VAPA,FG,VAOA,TYPE,RMPROBL,RC,AMIS,CST,DATE,DEL,RFLG,QTY,REM,SN,STA,RR,RO,I,J,RMPRCNUM,RMPRFG,TRANS,TRANS1,RK,FLG,RA,RI,RT,RTCH,LC,MC,RMPRDT,RMPRJOB,RMPRWO
- +7 KILL RMPR2APN,RMPRQ,RR5,R5,DFN,FL,PAGE,AN,FRM,VEN,RZ,%X,%Y,VA,VAERR,TLC,TMC,R660,RCK,RJ,RDA,RL,RTC,RTCD,RTHD,RTR,RW,RWP,RMPRQUES,RMPREND1
- DO KVAR^VADPT
- +8 if '$DATA(RMPRF)!($GET(RMPRBACK)<1)
- KILL RMPRDOB,RMPRDFN,RMPRNAM,RMPRSSN,RMPRBACK
- +9 KILL RMPOPFLG,RMPR1APN
- +10 QUIT
- QUEST1 SET RMPRQUES=1
- +1 NEW DIR
- SET DIR(0)="E"
- WRITE !!
- DO ^DIR
- WRITE @IOF
- +2 IF $DATA(DTOUT)!($DATA(DUOUT))
- SET RMPREND1=1
- GOTO ASK1
- +3 WRITE !
- QUIT
- QUEST2 ;PUT MAS DISABILITY CODES ON NEXT PAGE IF THEY WILL NOT ALL FIT ON THIS
- +1 ;PAGE
- +2 NEW DIR
- SET DIR(0)="E"
- WRITE !!
- DO ^DIR
- WRITE @IOF
- SET RMNOQUIT=1
- +3 IF $DATA(DTOUT)!($DATA(DUOUT))
- SET RMNOQUIT=0
- +4 WRITE @IOF
- +5 QUIT