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

RMPR5HQ5.m

Go to the documentation of this file.
  1. RMPR5HQ5 ;HCIOFO/ODJ - INVENTORY REPORT - BUILD ^TMP SORT ARRAY ; 20 SEP 00
  1. ;;3.0;PROSTHETICS;**51,61,127**;Feb 09, 1996
  1. ;
  1. ;RVD -patch #61 - modified to read the new PIP files; 661.11, 661.6
  1. ; 661.7, 661.9
  1. Q
  1. ;
  1. ; Start of Report build and print. Enter here after report params.
  1. ; entered by user (see RMPR5HQ4).
  1. ; Also called by TaskMan if report queued.
  1. ;
  1. ; Variables required
  1. ;
  1. ; RMPR("STA")
  1. ; RMPRSDT
  1. ; RMPREDT
  1. ; RMPRDET
  1. ; RMPRSEL
  1. ; {IO vars}
  1. ;
  1. REPORT I $E(IOST)["C" W !!,"Processing report......."
  1. D GEN(RMPRSDT,RMPREDT,RMPRDET,.RMPRSEL,RMPR("STA")) ;generate ^TMP sort array
  1. D CALC^RMPR5HQ6 ;calculations
  1. U IO D ^RMPR5HQ2 ;print report
  1. D ^%ZISC
  1. ;K ^TMP($J,"RMPR5") ;make live after testing
  1. N RMPR,RMPRSITE D KILL^XUSCLEAN
  1. Q
  1. ;
  1. ; Entry point for national roll-up
  1. NATION N RMPRSEL,RMPRDET,RMPRSTN,RMPRSDT,RMPREDT,X,RSTN
  1. S RMPRSTN="*"
  1. S RMPRDET="H"
  1. ;D NOW^%DTC S RMPREDT=X S %H=%H-30 D YMD^%DTC S RMPRSDT=X
  1. S RMPRSDT=RMPRPIP1,RMPREDT=RMPRPIP2
  1. S RMPRSEL("*")=""
  1. D GEN(RMPRSDT,RMPREDT,RMPRDET,.RMPRSEL,RMPRSTN)
  1. D CALC^RMPR5HQ6 ;put calcs in TMP array
  1. D MAIL^RMPR5HQ7 ;build ^TMP($J,"RMPR5A" array for mailing
  1. Q
  1. ;
  1. ;
  1. ; Generate temporary index global ^TMP($J,"RMPR5"
  1. ; (as of 11/29/00 we use the 660 file, not 661.2)
  1. ;
  1. GEN(STDT,ENDT,DETAIL,RMPRSEL,RMPRSTN) ;
  1. N TNAM,FROM,EOF,DAT,HCDAT,HCPCIEN,NPGRP,NPLIN,S,HCPC,HCPCITEM
  1. N OUPIEN,ITEM,ALLGRP,HCPCREF,SELECTED,STATION,QTY,STR,MULITEM
  1. N ITMIEN,INVDT,SOURCE,ISCOST,PATIENT,COST
  1. S TNAM="RMPR5" ;TMP global name
  1. K ^TMP($J,TNAM)
  1. D CURVAL(TNAM,RMPRSTN,.RMPRSEL,DETAIL)
  1. ;S FROM="" S:$G(STDT)'="*" FROM=STDT-1
  1. S RSTN=RMPRSTN
  1. S:RMPRSTN="*" RSTN=0
  1. S EOF=0,ENDT=ENDT+1
  1. F RSTN=RSTN:0 S RSTN=$O(^RMPR(661.6,"XSTD",RSTN)) Q:RSTN'>0 D
  1. .F RSDT=STDT:0 S RSDT=$O(^RMPR(661.6,"XSTD",RSTN,3,RSDT)) Q:(RSDT>ENDT)!(RSDT="") D Q:EOF
  1. .. S OUPIEN=0
  1. .. F S OUPIEN=$O(^RMPR(661.6,"XSTD",RSTN,3,RSDT,OUPIEN)) Q:OUPIEN'>0 D
  1. ... S S=$G(^RMPR(661.6,OUPIEN,0))
  1. ... S PATIENT=$P(S,"^",2) Q:PATIENT=""
  1. ... S QTY=+$P(S,"^",5) Q:QTY<1
  1. ... S HCPC=$P(S,"^",1) Q:HCPC=""
  1. ... S HCPCIEN=$O(^RMPR(661.1,"B",HCPC,0)) Q:HCPCIEN=""
  1. ... S STATION=RSTN Q:STATION=""
  1. ... I RMPRSTN'="*",STATION'=RSTN Q
  1. ... Q:'$D(^TMP($J,TNAM,"Z",HCPCIEN))
  1. ... Q:$P(^TMP($J,TNAM,"Z",HCPCIEN),"^",3)=1
  1. ... S HCPCITEM=HCPC_"-"_$P(S,"^",11)
  1. ... S ITEM=$P(HCPCITEM,"-",2)
  1. ... S:ITEM="" ITEM="?"
  1. ... S ISCOST=$P(S,"^",6)
  1. ...; S COST=$$PRECOST(OUPIEN,HCPCIEN,HCPCITEM,STATION)
  1. ...; I COST'="" S ISCOST=COST-ISCOST
  1. ...; S:COST="" ISCOST=QTY*$P(S,"^",5)
  1. ... S R11=$O(^RMPR(661.11,"C",HCPCITEM,0))
  1. ... S R11DAT=$G(^RMPR(661.11,R11,0))
  1. ... S SOURCE=$P(R11DAT,"^",5)
  1. ... S STR=^TMP($J,TNAM,"Z",HCPCIEN)
  1. ... S NPGRP=$P(STR,"^",1)
  1. ... S NPLIN=$P(STR,"^",2)
  1. ... S HCPCREF=HCPC,$P(HCPCREF,"/",2)=HCPCIEN
  1. ... I '$D(^TMP($J,TNAM,STATION,NPGRP,NPLIN,HCPCREF,ITEM)) D Q:'+QTY
  1. .... S:+QTY ^TMP($J,TNAM,STATION,NPGRP,NPLIN,HCPCREF,ITEM)=""
  1. .... Q
  1. ... S ^TMP($J,TNAM,STATION,NPGRP,NPLIN,HCPCREF,ITEM,OUPIEN)=QTY_"^"_ISCOST_"^"_SOURCE
  1. ... Q
  1. .. Q
  1. Q
  1. ;
  1. ; Get total cost of item just prior to current issue
  1. PRECOST(INVIEN,HCPCIEN,HCPCITEM,STATION) ;
  1. N IEN,COST,STR,LOC
  1. S COST=""
  1. S IEN=INVIEN,RD=RMPRSDT
  1. S RD=$O(^RMPR(661.9,"ASHID",RSTN,HCPC,IEN,RD),-1)
  1. Q:'$G(RD) COST S RIEN=$O(^RMPR(661.9,"ASHID",RSTN,HCPC,IEN,RD,0))
  1. S STR=^RMPR(661.9,RIEN,0)
  1. S COST=$P(STR,"^",9)
  1. Q COST
  1. ;
  1. ; Get QOH for HCPC
  1. CURVAL(RMPRNAM,RMPRSTN,RMPRSEL,DETAIL) ;
  1. N INVIEN,STR,IEN1,IEN2,LOCN,HCPCIEN,HCDAT,NPLIN,NPGRP,ALLGRP,SELECTED
  1. N S,SOURCE,STATION,QOH,COST,HCPC,HCPCREF,ITEM,RSTN
  1. S ALLGRP=0 S:$O(RMPRSEL(""))="*" ALLGRP=1
  1. S RSTN=RMPRSTN
  1. S:RMPRSTN="*" RSTN=0
  1. F RSTN=RSTN:0 S RSTN=$O(^RMPR(661.9,"ASHID",RSTN)) Q:RSTN'>0 D
  1. .S RH=""
  1. .F S RH=$O(^RMPR(661.9,"ASHID",RSTN,RH)) Q:RH="" D
  1. .. S IEN1=0
  1. .. F S IEN1=$O(^RMPR(661.9,"ASHID",RSTN,RH,IEN1)) Q:'+IEN1 D
  1. ... S HCPCIEN=$O(^RMPR(661.1,"B",RH,0)) Q:HCPCIEN=""
  1. ... I '$D(^TMP($J,RMPRNAM,"Z",HCPCIEN)) D
  1. .... S S=^RMPR(661.1,HCPCIEN,0)
  1. .... S NPLIN=$P(S,"^",7)
  1. .... S:NPLIN="" NPLIN="999 X"
  1. .... S NPGRP=$P(NPLIN," ",1) ;group num. is 1st set of digits of new line
  1. .... S STR=NPGRP
  1. .... S $P(STR,"^",2)=NPLIN
  1. .... S ^TMP($J,RMPRNAM,"Z",HCPCIEN)=STR
  1. .... Q
  1. ... E D Q:$P(S,"^",3)=1
  1. .... S S=^TMP($J,RMPRNAM,"Z",HCPCIEN)
  1. .... S NPGRP=$P(S,"^",1)
  1. .... S NPLIN=$P(S,"^",2)
  1. .... Q
  1. ... ;
  1. ... ; Test if record matches selection criteria
  1. ... ; (only needed if not all groups selected)
  1. ... I 'ALLGRP D I 'SELECTED S $P(^TMP($J,RMPRNAM,"Z",HCPCIEN),"^",3)=1 Q
  1. .... S SELECTED=0
  1. .... I '$D(RMPRSEL(NPGRP)) Q
  1. .... I DETAIL="G" S SELECTED=1 Q
  1. .... I $O(RMPRSEL(NPGRP,""))="*" S SELECTED=1 Q
  1. .... I '$D(RMPRSEL(NPGRP,NPLIN)) Q
  1. .... I DETAIL="L" S SELECTED=1 Q
  1. .... I $O(RMPRSEL(NPGRP,NPLIN,""))="*" S SELECTED=1 Q
  1. .... I '$D(RMPRSEL(NPGRP,NPLIN,HCPCIEN)) Q
  1. .... S SELECTED=1
  1. .... Q
  1. ... S RD=ENDT+1
  1. ... S RD=$O(^RMPR(661.9,"ASHID",RSTN,RH,IEN1,RD),-1) Q:RD="" S RIEN=$O(^RMPR(661.9,"ASHID",RSTN,RH,IEN1,RD,""),-1) D
  1. .... S HCPC=RH,S=^RMPR(661.9,RIEN,0)
  1. .... S QOH=+$P(S,"^",8) Q:'QOH
  1. .... S COST=$P(S,"^",9)
  1. .... S ITEM=IEN1
  1. .... S RS=$O(^RMPR(661.11,"C",HCPC_"-"_ITEM,0)) Q:RS=""
  1. .... S SOURCE=$P($G(^RMPR(661.11,RS,0)),U,5)
  1. .... S HCPCREF=HCPC,$P(HCPCREF,"/",2)=HCPCIEN
  1. .... S S=$G(^TMP($J,RMPRNAM,RSTN,NPGRP,NPLIN,HCPCREF,ITEM))
  1. .... I SOURCE="C" D
  1. ..... S $P(S,"^",9)=QOH+$P(S,"^",9)
  1. ..... S $P(S,"^",11)=COST+$P(S,"^",11)
  1. ..... Q
  1. .... E D
  1. ..... S $P(S,"^",8)=QOH+$P(S,"^",8)
  1. ..... S $P(S,"^",10)=COST+$P(S,"^",10)
  1. ..... Q
  1. .... S ^TMP($J,RMPRNAM,RSTN,NPGRP,NPLIN,HCPCREF,ITEM)=S
  1. .... Q
  1. ... Q
  1. .. Q
  1. Q
  1. ;
  1. ; return item text string given HCPC and ITEM IENs to 661.11
  1. ; if null ITEMIEN passed the just return the HCPC short name text
  1. GETITEM(HCPCIEN,ITEMIEN) ;
  1. N STR,ITEMTXT
  1. S ITEMTXT=""
  1. I ITEMIEN="" D G GETITEMX
  1. . S STR=$G(^RMPR(661.1,HCPCIEN,0))
  1. . S ITEMTXT=$P(STR,"^",2)
  1. . Q
  1. S HCPC=$P($G(^RMPR(661.1,HCPCIEN,0)),U,1)
  1. S STR=$G(^RMPR(661.11,"C",HCPC_"-"_ITEMIEN,0))
  1. I STR="" D
  1. . S ITEMTXT=$P(^RMPR(661.1,HCPCIEN,0),"^",2)
  1. . Q
  1. E D
  1. . S ITEMTXT=$P(STR,"^",1)
  1. . Q
  1. S:ITEMTXT="" ITEMTXT="ITEM "_ITEMIEN
  1. GETITEMX Q ITEMTXT
  1. ;
  1. ; return NPPD line text from line code (New lines only)
  1. NPLIN(CODE) ;
  1. N I,S,LINTXT
  1. S LINTXT=""
  1. F I=1:1 S S=$P($T(DES+I^RMPRN62),";;",2) Q:$E(S,1,3)="END" D Q:LINTXT'=""
  1. . I $P(S,";",1)=CODE S LINTXT=$P(S,";",2)
  1. . Q
  1. Q LINTXT