Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RMPR5HQ4

RMPR5HQ4.m

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