RMPR5HQ4 ;HCIOFO/ODJ - INVENTORY REPORT - PARAMETER DATA ENTRY ; 20 SEP 00
;;3.0;PROSTHETICS;**51,84,103,152**;Feb 09, 1996;Build 3
;
; AAC Patch 84, 02-25-04, additions, deletions and change descriptions for Groups and lines.
;
; Prompts for Station, Start date, End date, level of detail,
; NPPD group, NPPD line, HCPC selections and Report Device
START N RMPRSDT,RMPREDT,RMPREXC,RMPRSEL,RMPRHTY,RMPRGLST,RMPRLINX
N RMPRI,RMPRJ,RMPRLCN,RMPRHCN,RMPR,RMPRGRPA,RMPRVISN
; RMPR("STA") Station Number (ien ^DIC(4)
S RMPRSDT="" ; start date VM internal
S RMPREDT=DT ; end date VM internal
I '$D(RMPRDET) N RMPRDET S RMPRDET="" ; Level of detail
S RMPRHTY="" ; type of HCPCS selection
S RMPRLCN=1 ; Count for number of individual NPPD lines selected
S RMPRHCN=1 ; Count for number of individual HCPCs selected
K RMPREXC ; Exit condition from prompts (^ defined as quit)
K RMPRSEL ; Array of parameter selections
; If this array gets too big then need to save in ^TMP
; in which case queuing option will have to be removed
;
D GRPLST(.RMPRGLST) ;set list of NPPD group codes for DIR prompt
D GRPARY(.RMPRGRPA)
D SETLIN(.RMPRLINX) ;set an indexing array for NPPD line help
S RMPREXC=$$STN(.RMPR,.RMPRVISN)
I RMPREXC="^" G EDX
S RMPREXC=$$STDT(.RMPRSDT) ;get Start Date (fileman format)
I RMPREXC="^" G EDX
S RMPREXC=$$ENDT(.RMPREDT,RMPRSDT) ;get End Date (fileman format)
I RMPREXC="^" G EDX
I RMPRDET="" S RMPREXC=$$LEV(.RMPRDET) ;get Level of Detail
I RMPREXC="^" G EDX
I RMPRDET="G" K RMPRSEL S RMPRSEL("*")="" G EDDEV ;NPPD group level of detail
I RMPRDET="L" G EDLIN ;NPPD line level of detail
I RMPRDET="H"!(RMPRDET="I") G EDHCPC ;HCPC or Item level of detail
;
; NPPD Group level of detail
EDGRP S RMPREXC=$$NPGRP(.RMPRSEL)
I RMPREXC="^" G EDX
G EDDEV
;
; NPPD Line level of detail
EDLIN S RMPREXC=$$NPLIN(.RMPRSEL)
I RMPREXC="^" G EDX
EDLINX G EDDEV
;
; HCPC level of detail
EDHCPC S RMPREXC=$$HCPCTY(.RMPRHTY)
I RMPREXC="^" G EDX
I RMPRHTY="" G EDDEV
I RMPRHTY="A" K RMPRSEL S RMPRSEL("*")="" G EDDEV
I RMPRHTY="G" S RMPREXC=$$NPGRP(.RMPRSEL) G EDDEV
I RMPRHTY="L" S RMPREXC=$$NPLIN(.RMPRSEL) G EDDEV
S RMPREXC=$$HCPC(.RMPRSEL,.RMPRHCN)
G EDDEV
;
; Get device and run report or queue it
EDDEV S RMPREXC=$$REPDEV("")
I RMPREXC="^" G EDX
I '$D(IO("Q")) D REPORT^RMPR5HQ5 G EDX
K IO("Q")
S ZTDESC="INVENTORY REPORT",ZTRTN="REPORT^RMPR5HQ5",ZTIO=ION
S ZTSAVE("RMPRSDT")=""
S ZTSAVE("RMPREDT")=""
S ZTSAVE("RMPRDET")=""
S ZTSAVE("RMPRSEL(")=""
;S ZTSAVE("IOM")=""
S ZTSAVE("RMPR(""STA"")")=""
D ^%ZTLOAD
W:$D(ZTSK) !,"REQUEST QUEUED!" H 1
EDX Q
;
; Prompt for Site/Station
STN(RMPR,RMPRVISN) ;
N X,Y,DIC,DA
S RMPRVISN=""
D DIV4^RMPRSIT ; call standard Prosthetic site look-up
I $D(X) S X="^"
E S X="" S:RMPRSITE'="" RMPRVISN=$P($G(^RMPR(669.9,RMPRSITE,"INV")),"^",2)
Q X
;
; Prompt for level of detail
EN1 N RMPRDET S RMPRDET="G" ;entry point NPPD Group level
G START
EN2 N RMPRDET S RMPRDET="L" ;entry point NPPD Line level
G START
EN3 N RMPRDET S RMPRDET="H" ;entry point HCPCS level
G START
EN4 N RMPRDET S RMPRDET="I" ;entry point Item level
G START
LEV(RMPRDET) ;
N DIR,X,Y
S RMPRDET=$G(RMPRDET)
S DIR(0)="S^G:NPPD Group;L:NPPD Line;H:HCPCS Code;I:HCPCS Item"
S DIR("A")="Select inventory report level of detail"
D ^DIR
I Y="",$D(DTOUT) S X="^" G LEVX
I Y="^"!(Y="^^") S X="^" G LEVX
S RMPRDET=Y
LEVX Q X
;
; Prompt for Start Date
STDT(RMPRSDT) ; RMPRSDT is start date in FM internal form
N %DT,X,Y
S %DT("A")="Beginning Date: "
S %DT(0)=-DT
S %DT="AEP"
D ^%DT
I Y<0 S X="^"
S RMPRSDT=$P(Y,".",1)
Q X
;
; Prompt for End Date
ENDT(RMPREDT,RMPRSDT) ; RMPREDT is end date in FM internal form
N %DT,X,Y
ENDT1 S %DT("A")="Ending Date: "
S %DT(0)=-DT
S %DT="AEP"
D ^%DT
I Y<0 S X="^" G ENDT1X
S RMPREDT=$P(Y,".",1)
I RMPREDT<RMPRSDT W !,"Ending date should not precede start date",! G ENDT1
ENDT1X Q X
;
; Prompt for NPPD group
NPGRP(RMPRSEL) ;
N DIR,DA,X,Y,RMPRCNT,RMPRI,RMPRJ,RMPRGRP
W !
F RMPRCNT=1:1:$L(RMPRGLST,";") D
. W !,$J(RMPRCNT,2)_". "_$P($P(RMPRGLST,";",RMPRCNT),":",2)
. Q
S DIR(0)="L" S:$D(RMPRSEL) DIR(0)=DIR(0)_"O"
S DIR("A")="Select NPPD Group "
S $P(DIR(0),U,2)="1:"_RMPRCNT
D ^DIR
I Y="",$D(DTOUT) S X="^" G NPGRPX
I Y="^"!(Y="^^") S X="^" G NPGRPX
I Y="" S X="" G NPGRPX ; no selection so just exit
;
; add in the new selections
S RMPRI=""
F S RMPRI=$O(Y(RMPRI)) Q:RMPRI="" D Q:RMPRI=""
. I $L(Y(RMPRI),",")-1=RMPRCNT D Q
.. K RMPRSEL
.. S RMPRSEL("*")="" ; all groups selected
.. S RMPRI=""
.. Q
. F RMPRJ=1:1:$L(Y(RMPRI),",")-1 D
.. S RMPRGRP=$P($P(RMPRGLST,";",$P(Y(RMPRI),",",RMPRJ)),":",1)
.. K RMPRSEL(RMPRGRP)
.. S RMPRSEL(RMPRGRP,"*")=""
.. Q
. Q
NPGRPX Q X
;
; Prompt for NPPD line
; User can select lines within a group
; If more than 1 group selected must use all lines within those groups
NPLIN(RMPRSEL) ;
N DIR,DA,X,Y,RMPRHPG,RMPRGRP,RMPRLIN,RMPREXC,RMPRI,RMPRJ
S DIR(0)="L" S:$D(RMPRSEL) DIR(0)=DIR(0)_"O"
NPLIN1C S RMPREXC=$$NPGRP(.RMPRSEL)
I RMPREXC="^" S X="^" G NPLIN1X
I $O(RMPRSEL(""))="*" S X="" G NPLIN1X
S RMPRI=0,RMPRJ="" F S RMPRJ=$O(RMPRSEL(RMPRJ)) Q:RMPRJ="" S RMPRI=RMPRI+1 Q:RMPRI=2
I RMPRI=2 S X="" G NPLIN1X
S RMPRGRP=$O(RMPRSEL("")) K RMPRSEL
NPLIN1A D NPLINH(RMPRGRP,.RMPRHPG)
S $P(DIR(0),U,2)="1:"_RMPRHPG
S DIR("A")="Select NPPD line(s) within the above group"
D ^DIR
I Y="",$D(DTOUT) S X="^" G NPLIN1X
I Y="^"!(Y="^^") S X="^" G NPLIN1X
I Y="" S X="" G NPLIN1X
S RMPRI=""
F S RMPRI=$O(Y(RMPRI)) Q:RMPRI="" D Q:RMPRI=""
. I $L(Y(RMPRI),",")-1=RMPRHPG D Q
.. K RMPRSEL(RMPRGRP)
.. S RMPRSEL(RMPRGRP,"*")="" ; all lines selected
.. S RMPRI=""
.. Q
. F RMPRJ=1:1:$L(Y(RMPRI),",")-1 D
.. D NPLINC(RMPRGRP,$P(Y(RMPRI),",",RMPRJ),.RMPRLIN)
.. K RMPRSEL(RMPRGRP,RMPRLIN)
.. S RMPRSEL(RMPRGRP,RMPRLIN,"*")=""
.. Q
. Q
S X=""
NPLIN1X Q X
;
; Check entered NPPD line
; OFFS = line offset in RMPRN62 if valid NPPD line (else null)
;
NPLINC(RMPRGRP,INP,RMPRLIN) ;
N S,OFFS
S OFFS=RMPRLINX(RMPRGRP)+INP-1
S S=$P($T(DES+OFFS^RMPRN62),";;",2)
S RMPRLIN=$P(S,";",1)
Q
;
; Display NPPD lines for a given group
NPLINH(RMPRGRP,TO) ;
N FR,I,S,LINCD
W !,"NPPD Lines for Group: ",RMPRGRP," - ",RMPRGRPA(RMPRGRP),!
S FR=RMPRLINX(RMPRGRP)
S TO=0
F S S=$P($T(DES+FR^RMPRN62),";;",2),LINCD=$P(S,";",1) Q:$P(LINCD," ",1)'=RMPRGRP D
. S TO=TO+1
. W !,$J(TO,2),". ",$P(S,";",1)_" "_$P(S,";",2)
. W:$D(RMPRSEL(RMPRGRP,LINCD)) ?65,"<< Selected"
. S FR=FR+1
. Q
Q
;
; Select type of HCPCS selection
HCPCTY(RMPRHTY) ;
N DIR,DA,X,Y
S DIR("B")="A"
S DIR(0)="S^A:ALL HCPCS;G:ALL HCPCS for NPPD group;L:ALL HCPCS for NPPD line;S:Select individual HCPCS"
S DIR("A")="Choose HCPCS selection option"
D ^DIR
I Y="",$D(DTOUT) S X="^" G HCPCTYX
I Y="^"!(Y="^^") S X="^" G HCPCTYX
I X="" S RMPRHTY="" G HCPCTYX
S RMPRHTY=Y
HCPCTYX Q X
;
; Select HCPCS
HCPC(RMPRSEL,RMPRSCN) ;
N DIC,X,Y,DA,RMPRLIN
S DIC="^RMPR(661.1,",DIC(0)="AEQMZ"
HCPC1 S DIC("A")="Select HCPCS "_RMPRSCN_": "
D ^DIC
I $D(DTOUT) S X="^" G HCPCX
I $D(DUOUT) S X="^" G HCPCX
I X="" G HCPCX
S RMPRLIN=$P(Y(0),U,7)
S:RMPRLIN="" RMPRLIN="999 X"
S RMPRSEL($P(RMPRLIN," ",1),RMPRLIN,$P(Y,U,1))=""
S RMPRSCN=RMPRSCN+1
G HCPC1
HCPCX Q X
;
; Select Report device
REPDEV(RMPRDEV) ;
N X,POP,Y,%ZIS,IOP
REPDEV1 S X=""
S %ZIS="MQ" K IOP D ^%ZIS I POP S X="^" G REPDEVX
I IOM<132 W !,"You need at least 132 columns for this report.",!,"Please use a device capable of this requirement.",! G REPDEV1
REPDEVX Q X
;
; LINX is an array used in the help system within NPPD line selection
; Basically each page of help will show lines for a group.
; Each page has a start line corresponding to an offset in RMPRN62
SETLIN(LINX) ;
N I,HLPPG,S,LINCD,LINCD0
S HLPPG=0,LINCD0=""
F I=1:1 S S=$T(DES+I^RMPRN62) D Q:LINCD0=""
. S LINCD=$P($P(S,";;",2),";",1)
. S HLPPG=$P(LINCD," ",1)
. I $E(HLPPG)'?1N S LINX(HLPPG)=I,LINCD0="" Q
. I HLPPG'=LINCD0 D Q
.. S LINX(HLPPG)=I,LINCD0=HLPPG
.. Q
. Q
Q
;
; Set NPPD (new) group codes and desc. for use in DIR
; set of codes prompt.
; Hard coded, but better if in Fileman file sometime
; Codes and desc. copied from RMPRN6UT
GRPLST(LIST) ;
S LIST="100:WHEELCHAIRS AND ACCESSORIES"
S $P(LIST,";",2)="200:ARTIFICIAL LEGS"
S $P(LIST,";",3)="300:ARTIFICIAL ARMS AND TERMINAL DEVICES"
S $P(LIST,";",4)="400:ORTHOSIS/ORTHOTICS"
S $P(LIST,";",5)="500:SHOES/ORTHOTICS"
S $P(LIST,";",6)="600:SENSORI-NEURO AIDS"
S $P(LIST,";",7)="700:RESTORATIONS"
S $P(LIST,";",8)="800:OXYGEN AND RESPIRATORY"
S $P(LIST,";",9)="900:MEDICAL EQUIPMENT"
S $P(LIST,";",10)="910:ALL OTHER SUPPLIES AND EQUIPMENT"
S $P(LIST,";",11)="920:HOME DIALYSIS PROGRAM"
S $P(LIST,";",12)="930:ADAPTIVE EQUIPMENT"
S $P(LIST,";",13)="940:HISA"
S $P(LIST,";",14)="960:SURGICAL IMPLANTS"
S $P(LIST,";",15)="970:BIOLOGICAL IMPLANTS"
S $P(LIST,";",16)="999:MISC"
Q
;
; Same as above but set into array
GRPARY(ARRAY) ;
N LIST,I
K ARRAY
D GRPLST(.LIST)
F I=1:1:$L(LIST,";") S ARRAY($P($P(LIST,";",I),":",1))=$P($P(LIST,";",I),":",2)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR5HQ4 9384 printed Apr 09, 2024@21:37:16 Page 2
RMPR5HQ4 ;HCIOFO/ODJ - INVENTORY REPORT - PARAMETER DATA ENTRY ; 20 SEP 00
+1 ;;3.0;PROSTHETICS;**51,84,103,152**;Feb 09, 1996;Build 3
+2 ;
+3 ; AAC Patch 84, 02-25-04, additions, deletions and change descriptions for Groups and lines.
+4 ;
+5 ; Prompts for Station, Start date, End date, level of detail,
+6 ; NPPD group, NPPD line, HCPC selections and Report Device
START NEW RMPRSDT,RMPREDT,RMPREXC,RMPRSEL,RMPRHTY,RMPRGLST,RMPRLINX
+1 NEW RMPRI,RMPRJ,RMPRLCN,RMPRHCN,RMPR,RMPRGRPA,RMPRVISN
+2 ; RMPR("STA") Station Number (ien ^DIC(4)
+3 ; start date VM internal
SET RMPRSDT=""
+4 ; end date VM internal
SET RMPREDT=DT
+5 ; Level of detail
IF '$DATA(RMPRDET)
NEW RMPRDET
SET RMPRDET=""
+6 ; type of HCPCS selection
SET RMPRHTY=""
+7 ; Count for number of individual NPPD lines selected
SET RMPRLCN=1
+8 ; Count for number of individual HCPCs selected
SET RMPRHCN=1
+9 ; Exit condition from prompts (^ defined as quit)
KILL RMPREXC
+10 ; Array of parameter selections
KILL RMPRSEL
+11 ; If this array gets too big then need to save in ^TMP
+12 ; in which case queuing option will have to be removed
+13 ;
+14 ;set list of NPPD group codes for DIR prompt
DO GRPLST(.RMPRGLST)
+15 DO GRPARY(.RMPRGRPA)
+16 ;set an indexing array for NPPD line help
DO SETLIN(.RMPRLINX)
+17 SET RMPREXC=$$STN(.RMPR,.RMPRVISN)
+18 IF RMPREXC="^"
GOTO EDX
+19 ;get Start Date (fileman format)
SET RMPREXC=$$STDT(.RMPRSDT)
+20 IF RMPREXC="^"
GOTO EDX
+21 ;get End Date (fileman format)
SET RMPREXC=$$ENDT(.RMPREDT,RMPRSDT)
+22 IF RMPREXC="^"
GOTO EDX
+23 ;get Level of Detail
IF RMPRDET=""
SET RMPREXC=$$LEV(.RMPRDET)
+24 IF RMPREXC="^"
GOTO EDX
+25 ;NPPD group level of detail
IF RMPRDET="G"
KILL RMPRSEL
SET RMPRSEL("*")=""
GOTO EDDEV
+26 ;NPPD line level of detail
IF RMPRDET="L"
GOTO EDLIN
+27 ;HCPC or Item level of detail
IF RMPRDET="H"!(RMPRDET="I")
GOTO EDHCPC
+28 ;
+29 ; NPPD Group level of detail
EDGRP SET RMPREXC=$$NPGRP(.RMPRSEL)
+1 IF RMPREXC="^"
GOTO EDX
+2 GOTO EDDEV
+3 ;
+4 ; NPPD Line level of detail
EDLIN SET RMPREXC=$$NPLIN(.RMPRSEL)
+1 IF RMPREXC="^"
GOTO EDX
EDLINX GOTO EDDEV
+1 ;
+2 ; HCPC level of detail
EDHCPC SET RMPREXC=$$HCPCTY(.RMPRHTY)
+1 IF RMPREXC="^"
GOTO EDX
+2 IF RMPRHTY=""
GOTO EDDEV
+3 IF RMPRHTY="A"
KILL RMPRSEL
SET RMPRSEL("*")=""
GOTO EDDEV
+4 IF RMPRHTY="G"
SET RMPREXC=$$NPGRP(.RMPRSEL)
GOTO EDDEV
+5 IF RMPRHTY="L"
SET RMPREXC=$$NPLIN(.RMPRSEL)
GOTO EDDEV
+6 SET RMPREXC=$$HCPC(.RMPRSEL,.RMPRHCN)
+7 GOTO EDDEV
+8 ;
+9 ; Get device and run report or queue it
EDDEV SET RMPREXC=$$REPDEV("")
+1 IF RMPREXC="^"
GOTO EDX
+2 IF '$DATA(IO("Q"))
DO REPORT^RMPR5HQ5
GOTO EDX
+3 KILL IO("Q")
+4 SET ZTDESC="INVENTORY REPORT"
SET ZTRTN="REPORT^RMPR5HQ5"
SET ZTIO=ION
+5 SET ZTSAVE("RMPRSDT")=""
+6 SET ZTSAVE("RMPREDT")=""
+7 SET ZTSAVE("RMPRDET")=""
+8 SET ZTSAVE("RMPRSEL(")=""
+9 ;S ZTSAVE("IOM")=""
+10 SET ZTSAVE("RMPR(""STA"")")=""
+11 DO ^%ZTLOAD
+12 if $DATA(ZTSK)
WRITE !,"REQUEST QUEUED!"
HANG 1
EDX QUIT
+1 ;
+2 ; Prompt for Site/Station
STN(RMPR,RMPRVISN) ;
+1 NEW X,Y,DIC,DA
+2 SET RMPRVISN=""
+3 ; call standard Prosthetic site look-up
DO DIV4^RMPRSIT
+4 IF $DATA(X)
SET X="^"
+5 IF '$TEST
SET X=""
if RMPRSITE'=""
SET RMPRVISN=$PIECE($GET(^RMPR(669.9,RMPRSITE,"INV")),"^",2)
+6 QUIT X
+7 ;
+8 ; Prompt for level of detail
EN1 ;entry point NPPD Group level
NEW RMPRDET
SET RMPRDET="G"
+1 GOTO START
EN2 ;entry point NPPD Line level
NEW RMPRDET
SET RMPRDET="L"
+1 GOTO START
EN3 ;entry point HCPCS level
NEW RMPRDET
SET RMPRDET="H"
+1 GOTO START
EN4 ;entry point Item level
NEW RMPRDET
SET RMPRDET="I"
+1 GOTO START
LEV(RMPRDET) ;
+1 NEW DIR,X,Y
+2 SET RMPRDET=$GET(RMPRDET)
+3 SET DIR(0)="S^G:NPPD Group;L:NPPD Line;H:HCPCS Code;I:HCPCS Item"
+4 SET DIR("A")="Select inventory report level of detail"
+5 DO ^DIR
+6 IF Y=""
IF $DATA(DTOUT)
SET X="^"
GOTO LEVX
+7 IF Y="^"!(Y="^^")
SET X="^"
GOTO LEVX
+8 SET RMPRDET=Y
LEVX QUIT X
+1 ;
+2 ; Prompt for Start Date
STDT(RMPRSDT) ; RMPRSDT is start date in FM internal form
+1 NEW %DT,X,Y
+2 SET %DT("A")="Beginning Date: "
+3 SET %DT(0)=-DT
+4 SET %DT="AEP"
+5 DO ^%DT
+6 IF Y<0
SET X="^"
+7 SET RMPRSDT=$PIECE(Y,".",1)
+8 QUIT X
+9 ;
+10 ; Prompt for End Date
ENDT(RMPREDT,RMPRSDT) ; RMPREDT is end date in FM internal form
+1 NEW %DT,X,Y
ENDT1 SET %DT("A")="Ending Date: "
+1 SET %DT(0)=-DT
+2 SET %DT="AEP"
+3 DO ^%DT
+4 IF Y<0
SET X="^"
GOTO ENDT1X
+5 SET RMPREDT=$PIECE(Y,".",1)
+6 IF RMPREDT<RMPRSDT
WRITE !,"Ending date should not precede start date",!
GOTO ENDT1
ENDT1X QUIT X
+1 ;
+2 ; Prompt for NPPD group
NPGRP(RMPRSEL) ;
+1 NEW DIR,DA,X,Y,RMPRCNT,RMPRI,RMPRJ,RMPRGRP
+2 WRITE !
+3 FOR RMPRCNT=1:1:$LENGTH(RMPRGLST,";")
Begin DoDot:1
+4 WRITE !,$JUSTIFY(RMPRCNT,2)_". "_$PIECE($PIECE(RMPRGLST,";",RMPRCNT),":",2)
+5 QUIT
End DoDot:1
+6 SET DIR(0)="L"
if $DATA(RMPRSEL)
SET DIR(0)=DIR(0)_"O"
+7 SET DIR("A")="Select NPPD Group "
+8 SET $PIECE(DIR(0),U,2)="1:"_RMPRCNT
+9 DO ^DIR
+10 IF Y=""
IF $DATA(DTOUT)
SET X="^"
GOTO NPGRPX
+11 IF Y="^"!(Y="^^")
SET X="^"
GOTO NPGRPX
+12 ; no selection so just exit
IF Y=""
SET X=""
GOTO NPGRPX
+13 ;
+14 ; add in the new selections
+15 SET RMPRI=""
+16 FOR
SET RMPRI=$ORDER(Y(RMPRI))
if RMPRI=""
QUIT
Begin DoDot:1
+17 IF $LENGTH(Y(RMPRI),",")-1=RMPRCNT
Begin DoDot:2
+18 KILL RMPRSEL
+19 ; all groups selected
SET RMPRSEL("*")=""
+20 SET RMPRI=""
+21 QUIT
End DoDot:2
QUIT
+22 FOR RMPRJ=1:1:$LENGTH(Y(RMPRI),",")-1
Begin DoDot:2
+23 SET RMPRGRP=$PIECE($PIECE(RMPRGLST,";",$PIECE(Y(RMPRI),",",RMPRJ)),":",1)
+24 KILL RMPRSEL(RMPRGRP)
+25 SET RMPRSEL(RMPRGRP,"*")=""
+26 QUIT
End DoDot:2
+27 QUIT
End DoDot:1
if RMPRI=""
QUIT
NPGRPX QUIT X
+1 ;
+2 ; Prompt for NPPD line
+3 ; User can select lines within a group
+4 ; If more than 1 group selected must use all lines within those groups
NPLIN(RMPRSEL) ;
+1 NEW DIR,DA,X,Y,RMPRHPG,RMPRGRP,RMPRLIN,RMPREXC,RMPRI,RMPRJ
+2 SET DIR(0)="L"
if $DATA(RMPRSEL)
SET DIR(0)=DIR(0)_"O"
NPLIN1C SET RMPREXC=$$NPGRP(.RMPRSEL)
+1 IF RMPREXC="^"
SET X="^"
GOTO NPLIN1X
+2 IF $ORDER(RMPRSEL(""))="*"
SET X=""
GOTO NPLIN1X
+3 SET RMPRI=0
SET RMPRJ=""
FOR
SET RMPRJ=$ORDER(RMPRSEL(RMPRJ))
if RMPRJ=""
QUIT
SET RMPRI=RMPRI+1
if RMPRI=2
QUIT
+4 IF RMPRI=2
SET X=""
GOTO NPLIN1X
+5 SET RMPRGRP=$ORDER(RMPRSEL(""))
KILL RMPRSEL
NPLIN1A DO NPLINH(RMPRGRP,.RMPRHPG)
+1 SET $PIECE(DIR(0),U,2)="1:"_RMPRHPG
+2 SET DIR("A")="Select NPPD line(s) within the above group"
+3 DO ^DIR
+4 IF Y=""
IF $DATA(DTOUT)
SET X="^"
GOTO NPLIN1X
+5 IF Y="^"!(Y="^^")
SET X="^"
GOTO NPLIN1X
+6 IF Y=""
SET X=""
GOTO NPLIN1X
+7 SET RMPRI=""
+8 FOR
SET RMPRI=$ORDER(Y(RMPRI))
if RMPRI=""
QUIT
Begin DoDot:1
+9 IF $LENGTH(Y(RMPRI),",")-1=RMPRHPG
Begin DoDot:2
+10 KILL RMPRSEL(RMPRGRP)
+11 ; all lines selected
SET RMPRSEL(RMPRGRP,"*")=""
+12 SET RMPRI=""
+13 QUIT
End DoDot:2
QUIT
+14 FOR RMPRJ=1:1:$LENGTH(Y(RMPRI),",")-1
Begin DoDot:2
+15 DO NPLINC(RMPRGRP,$PIECE(Y(RMPRI),",",RMPRJ),.RMPRLIN)
+16 KILL RMPRSEL(RMPRGRP,RMPRLIN)
+17 SET RMPRSEL(RMPRGRP,RMPRLIN,"*")=""
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
if RMPRI=""
QUIT
+20 SET X=""
NPLIN1X QUIT X
+1 ;
+2 ; Check entered NPPD line
+3 ; OFFS = line offset in RMPRN62 if valid NPPD line (else null)
+4 ;
NPLINC(RMPRGRP,INP,RMPRLIN) ;
+1 NEW S,OFFS
+2 SET OFFS=RMPRLINX(RMPRGRP)+INP-1
+3 SET S=$PIECE($TEXT(DES+OFFS^RMPRN62),";;",2)
+4 SET RMPRLIN=$PIECE(S,";",1)
+5 QUIT
+6 ;
+7 ; Display NPPD lines for a given group
NPLINH(RMPRGRP,TO) ;
+1 NEW FR,I,S,LINCD
+2 WRITE !,"NPPD Lines for Group: ",RMPRGRP," - ",RMPRGRPA(RMPRGRP),!
+3 SET FR=RMPRLINX(RMPRGRP)
+4 SET TO=0
+5 FOR
SET S=$PIECE($TEXT(DES+FR^RMPRN62),";;",2)
SET LINCD=$PIECE(S,";",1)
if $PIECE(LINCD," ",1)'=RMPRGRP
QUIT
Begin DoDot:1
+6 SET TO=TO+1
+7 WRITE !,$JUSTIFY(TO,2),". ",$PIECE(S,";",1)_" "_$PIECE(S,";",2)
+8 if $DATA(RMPRSEL(RMPRGRP,LINCD))
WRITE ?65,"<< Selected"
+9 SET FR=FR+1
+10 QUIT
End DoDot:1
+11 QUIT
+12 ;
+13 ; Select type of HCPCS selection
HCPCTY(RMPRHTY) ;
+1 NEW DIR,DA,X,Y
+2 SET DIR("B")="A"
+3 SET DIR(0)="S^A:ALL HCPCS;G:ALL HCPCS for NPPD group;L:ALL HCPCS for NPPD line;S:Select individual HCPCS"
+4 SET DIR("A")="Choose HCPCS selection option"
+5 DO ^DIR
+6 IF Y=""
IF $DATA(DTOUT)
SET X="^"
GOTO HCPCTYX
+7 IF Y="^"!(Y="^^")
SET X="^"
GOTO HCPCTYX
+8 IF X=""
SET RMPRHTY=""
GOTO HCPCTYX
+9 SET RMPRHTY=Y
HCPCTYX QUIT X
+1 ;
+2 ; Select HCPCS
HCPC(RMPRSEL,RMPRSCN) ;
+1 NEW DIC,X,Y,DA,RMPRLIN
+2 SET DIC="^RMPR(661.1,"
SET DIC(0)="AEQMZ"
HCPC1 SET DIC("A")="Select HCPCS "_RMPRSCN_": "
+1 DO ^DIC
+2 IF $DATA(DTOUT)
SET X="^"
GOTO HCPCX
+3 IF $DATA(DUOUT)
SET X="^"
GOTO HCPCX
+4 IF X=""
GOTO HCPCX
+5 SET RMPRLIN=$PIECE(Y(0),U,7)
+6 if RMPRLIN=""
SET RMPRLIN="999 X"
+7 SET RMPRSEL($PIECE(RMPRLIN," ",1),RMPRLIN,$PIECE(Y,U,1))=""
+8 SET RMPRSCN=RMPRSCN+1
+9 GOTO HCPC1
HCPCX QUIT X
+1 ;
+2 ; Select Report device
REPDEV(RMPRDEV) ;
+1 NEW X,POP,Y,%ZIS,IOP
REPDEV1 SET X=""
+1 SET %ZIS="MQ"
KILL IOP
DO ^%ZIS
IF POP
SET X="^"
GOTO REPDEVX
+2 IF IOM<132
WRITE !,"You need at least 132 columns for this report.",!,"Please use a device capable of this requirement.",!
GOTO REPDEV1
REPDEVX QUIT X
+1 ;
+2 ; LINX is an array used in the help system within NPPD line selection
+3 ; Basically each page of help will show lines for a group.
+4 ; Each page has a start line corresponding to an offset in RMPRN62
SETLIN(LINX) ;
+1 NEW I,HLPPG,S,LINCD,LINCD0
+2 SET HLPPG=0
SET LINCD0=""
+3 FOR I=1:1
SET S=$TEXT(DES+I^RMPRN62)
Begin DoDot:1
+4 SET LINCD=$PIECE($PIECE(S,";;",2),";",1)
+5 SET HLPPG=$PIECE(LINCD," ",1)
+6 IF $EXTRACT(HLPPG)'?1N
SET LINX(HLPPG)=I
SET LINCD0=""
QUIT
+7 IF HLPPG'=LINCD0
Begin DoDot:2
+8 SET LINX(HLPPG)=I
SET LINCD0=HLPPG
+9 QUIT
End DoDot:2
QUIT
+10 QUIT
End DoDot:1
if LINCD0=""
QUIT
+11 QUIT
+12 ;
+13 ; Set NPPD (new) group codes and desc. for use in DIR
+14 ; set of codes prompt.
+15 ; Hard coded, but better if in Fileman file sometime
+16 ; Codes and desc. copied from RMPRN6UT
GRPLST(LIST) ;
+1 SET LIST="100:WHEELCHAIRS AND ACCESSORIES"
+2 SET $PIECE(LIST,";",2)="200:ARTIFICIAL LEGS"
+3 SET $PIECE(LIST,";",3)="300:ARTIFICIAL ARMS AND TERMINAL DEVICES"
+4 SET $PIECE(LIST,";",4)="400:ORTHOSIS/ORTHOTICS"
+5 SET $PIECE(LIST,";",5)="500:SHOES/ORTHOTICS"
+6 SET $PIECE(LIST,";",6)="600:SENSORI-NEURO AIDS"
+7 SET $PIECE(LIST,";",7)="700:RESTORATIONS"
+8 SET $PIECE(LIST,";",8)="800:OXYGEN AND RESPIRATORY"
+9 SET $PIECE(LIST,";",9)="900:MEDICAL EQUIPMENT"
+10 SET $PIECE(LIST,";",10)="910:ALL OTHER SUPPLIES AND EQUIPMENT"
+11 SET $PIECE(LIST,";",11)="920:HOME DIALYSIS PROGRAM"
+12 SET $PIECE(LIST,";",12)="930:ADAPTIVE EQUIPMENT"
+13 SET $PIECE(LIST,";",13)="940:HISA"
+14 SET $PIECE(LIST,";",14)="960:SURGICAL IMPLANTS"
+15 SET $PIECE(LIST,";",15)="970:BIOLOGICAL IMPLANTS"
+16 SET $PIECE(LIST,";",16)="999:MISC"
+17 QUIT
+18 ;
+19 ; Same as above but set into array
GRPARY(ARRAY) ;
+1 NEW LIST,I
+2 KILL ARRAY
+3 DO GRPLST(.LIST)
+4 FOR I=1:1:$LENGTH(LIST,";")
SET ARRAY($PIECE($PIECE(LIST,";",I),":",1))=$PIECE($PIECE(LIST,";",I),":",2)
+5 QUIT
