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

RMPRPIUH.m

Go to the documentation of this file. 
  1. RMPRPIUH ;HINCIO/ODJ - CONVERT OLD PIP TO NEW PIP ;3/8/05  11:45
  1.  ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
  1.  ; DBIA #10090 - Read Access to entire file #4.
  1.  Q
  1.  ;
  1.  ;***** CONV - Convert old PIP files to the new design
  1.  ;             continued from RMPRPIUG
  1.  ;             Create issue transactions
  1.  ;
  1.  ; Convert patient issues in 660 file
  1.  ;
  1.  ; Start loop at 1st date in 661.2
  1. CONV N RMPRDT,RMPRIEN,RMPRR60,RMPR62P,RMPRREC,RMPR6,RMPR11,RMPR62R,RMPRITM
  1.  N RMPR63P,RMPR63R,RMPR5,RMPRHIEN,RMPRS,RMPRERR,RMPRTIME,RMPR60
  1.  I '$D(IO("Q")) D
  1.  . W !,"Creating patient issue transactions - file 661.6 "
  1.  . Q
  1.  K ^TMP($J,"ISS")
  1.  S RMPRDT=$O(^RMPR(661.2,"B",""))
  1.  I RMPRDT'="" S RMPRDT=RMPRDT-1
  1.  ;
  1.  ; Loop on ENTRY DATE ('B') x-ref in 660 file
  1. CONV1 S RMPRDT=$O(^RMPR(660,"B",RMPRDT))
  1.  I '$D(IO("Q")) D
  1.  . W:$X=79 ! W "."
  1.  . Q
  1.  I RMPRDT="" G CONVX
  1.  S RMPRIEN=0
  1. CONV2 S RMPRIEN=$O(^RMPR(660,"B",RMPRDT,RMPRIEN))
  1.  I '+RMPRIEN G CONV1
  1.  ;
  1.  ; read 660 recs and set up arrays
  1.  K RMPR60
  1.  S RMPR60("IEN")=RMPRIEN
  1.  S RMPRR60=$G(^RMPR(660,RMPRIEN,1))
  1.  S RMPR62P=$P(RMPRR60,"^",5) ;pointer to 661.2
  1.  I RMPR62P="" G CONV2 ;ignore if null ptr.
  1.  I '$D(^RMPR(661.2,RMPR62P)) G CONV2 ;ignore if invalid ptr.
  1.  S RMPRREC=$G(^RMPR(660,RMPRIEN,0))
  1.  K RMPR6
  1.  I RMPRDT'=$P(RMPRREC,"^",1) G CONV2 ;bad 'B' x-ref
  1.  S RMPR6("QUANTITY")=+$P(RMPRREC,"^",7)
  1.  I RMPR6("QUANTITY")=0 G CONV2 ;ignore if 0 qty
  1.  S RMPR6("VALUE")=$P(RMPRREC,"^",16)
  1.  S RMPR6("VENDOR")=$P(RMPRREC,"^",9)
  1.  I RMPR6("VENDOR")="" G CONV2 ;ignore if null vendor
  1.  S RMPR6("USER")=$P(RMPRREC,"^",27)
  1.  ;
  1.  ; Get HCPCS and HCPCS Item using file 661.2
  1.  S RMPR62R=$G(^RMPR(661.2,RMPR62P,0))
  1.  S RMPR60("661.2PTR")=RMPR62P
  1.  K RMPR11
  1.  S RMPR11("ITEM MASTER IEN")=$P(RMPRREC,"^",6)
  1.  S RMPR11("STATION")=$P(RMPR62R,"^",15)
  1.  I RMPR11("STATION")="" G CONV2 ;ignore if null station
  1.  I '$D(^DIC(4,RMPR11("STATION"),0)) G CONV2 ;ignore if bad ptr
  1.  S RMPR11("HCPCS")=$P($P(RMPR62R,"^",9),"-",1) ;HCPCS Code
  1.  I RMPR11("HCPCS")="" G CONV2 ;ignore if null HCPCS
  1.  S RMPRHIEN=$P(RMPR62R,"^",4) ;HCPCS ptr
  1.  I RMPRHIEN="" G CONV2 ;ignore if null HCPCS ptr
  1.  S RMPRITM=$P($P(RMPR62R,"^",9),"-",2) ;Item ptr
  1.  I RMPRITM="" G CONV2 ;ignore if null item
  1.  S RMPR11("SOURCE")=$P(RMPR62R,"^",3)
  1.  I RMPR11("SOURCE")'="V" S RMPR11("SOURCE")="C"
  1.  S RMPR11("UNIT")=$P(RMPR62R,"^",5)
  1.  D GETITM(.RMPR11,RMPRHIEN,RMPRITM)
  1.  ;
  1.  ; Get Location
  1.  K RMPR5
  1.  S RMPR63P=$P(RMPR62R,"^",16) ;ptr to location 661.3 file
  1.  S RMPR5("STATION")=RMPR11("STATION")
  1.  S RMPRERR=$$GETLCN(RMPR63P,.RMPR5) ; get location
  1.  I RMPRERR G CONV2 ;ignore if bad location
  1.  ;
  1.  ; If get here then enough to create a stock issue to patient
  1.  ; transaction...
  1.  S RMPR6("DATE&TIME")=""
  1.  F  D  Q:RMPR6("DATE&TIME")'=""
  1.  . D NOW^%DTC
  1.  . S RMPRTIME=RMPRDT_"."_$P(%,".",2)
  1.  . I $D(^RMPR(661.6,"XHDS",RMPR11("HCPCS"),RMPRTIME)) H (1+$R(3)) Q
  1.  . L +^RMPR(661.6,"XHDS",RMPR11("HCPCS"),RMPRTIME):0 E  H (1+$R(3)) Q
  1.  . S RMPR6("DATE&TIME")=RMPRTIME
  1.  . Q
  1.  S RMPR6("LOCATION")=RMPR5("IEN")
  1.  S RMPRS=$G(^TMP($J,"ISS",RMPR11("STATION"),RMPR11("HCPCS"),RMPR11("ITEM"),RMPR6("LOCATION"),RMPR6("VENDOR")))
  1.  S $P(RMPRS,"^",1)=RMPR6("QUANTITY")+$P(RMPRS,"^",1)
  1.  S $P(RMPRS,"^",2)=RMPR6("VALUE")+$P(RMPRS,"^",2)
  1.  S ^TMP($J,"ISS",RMPR11("STATION"),RMPR11("HCPCS"),RMPR11("ITEM"),RMPR6("LOCATION"),RMPR6("VENDOR"))=RMPRS
  1.  S RMPR6("SEQUENCE")=1
  1.  S RMPR6("COMMENT")=""
  1.  S RMPR6("TRAN TYPE")=3
  1.  S RMPRERR=$$CRE^RMPRPIX6(.RMPR6,.RMPR11)
  1.  S $P(RMPRR60,"^",5)=RMPR6("IEN")
  1.  S ^RMPR(660,RMPRIEN,1)=RMPRR60
  1.  L -^RMPR(661.6,"XHDS",RMPR11("HCPCS"),RMPR6("DATE&TIME"))
  1.  ;
  1.  ; Create 661.63 Patient Issue transaction record
  1.  S RMPRERR=$$CRE^RMPRPIX3(.RMPR60,.RMPR6,.RMPR11)
  1.  ;
  1.  ; Next rec
  1.  G CONV2
  1.  ;
  1.  ; Exit
  1. CONVX Q
  1.  ;
  1.  ; Get a Location from the pointer to file 661.3
  1.  ; RMPRPIUJ should have been already run to set up the new locations
  1.  ; file 661.5 and the temp map file.
  1.  ; If can't get a valid location default to the GENERIC location
  1. GETLCN(RMPR63P,RMPR5) ;
  1.  N RMPRERR
  1.  S RMPRERR=0
  1.  I RMPR63P="" S RMPRERR=1 G GETLCNX
  1.  I '$D(^RMPR(661.5,"XSL",RMPR5("STATION"))) S RMPRERR=2 G GETLCNX
  1.  ;
  1.  ; if old (661.3) pointer mapped to new (661.5) pointer use it 
  1.  I $D(^TMP($J,"LOCN",RMPR63P)) D  G GETLCNX
  1.  . S RMPR5("IEN")=^TMP($J,"LOCN",RMPR63P)
  1.  . Q
  1.  ;
  1.  ; else use the 661.5 pointer for GENERIC location
  1.  E  D
  1.  . S RMPR5("IEN")=$O(^RMPR(661.5,"XSL",RMPR5("STATION"),"GENERIC",""))
  1.  . Q
  1. GETLCNX Q RMPRERR
  1.  ;
  1.  ; Get HCPCS Item
  1.  ; Commercial items should have already been set up by running
  1.  ; RMPRPIUI
  1.  ; VA items and those items in 661.2 which are no longer in the 661.3
  1.  ; file will be created together with a map of old to new iens.
  1. GETITM(RMPR11,RMPRHIEN,RMPRITM) ;
  1.  N RMPRI,RMPRS,RMPRERR,RMPRIM,RMPR11U,RMPRGOT
  1.  S RMPR11("ITEM MASTER IEN")=$G(RMPR11("ITEM MASTER IEN"))
  1.  S RMPRIM=RMPR11("ITEM MASTER IEN")
  1.  S:RMPRIM="" RMPRIM="*"
  1.  ;
  1.  ; If item has new number from previous update then use the temp map
  1.  I $D(^TMP($J,"ITEM",RMPRHIEN,RMPRITM,RMPR11("SOURCE"),RMPRIM)) D  G GETITMX
  1.  . S RMPRS=^TMP($J,"ITEM",RMPRHIEN,RMPRITM,RMPR11("SOURCE"),RMPRIM)
  1.  . S RMPR11("ITEM")=$P(RMPRS,"^",3)
  1.  . Q
  1.  ;
  1.  ; If item number not already in use then can use it to create a new
  1.  ; item in file 661.11
  1.  I '$D(^RMPR(661.11,"ASHI",RMPR11("STATION"),RMPR11("HCPCS"),RMPRITM)) S RMPR11("ITEM")=RMPRITM G GETITM1
  1.  ;
  1.  ; Ensure not duplicating Item number for different source
  1.  S RMPRGOT=0
  1.  S RMPRI=$O(^RMPR(661.11,"ASHI",RMPR11("STATION"),RMPR11("HCPCS"),RMPRITM,""))
  1.  S RMPRS=^RMPR(661.11,RMPRI,0)
  1.  I $P(RMPRS,"^",5)=RMPR11("SOURCE") D
  1.  . I $P(RMPRS,"^",8)=RMPR11("ITEM MASTER IEN") S RMPRGOT=1 Q
  1.  . I $P(RMPRS,"^",8)="" D
  1.  .. K RMPR11U
  1.  .. S RMPR11U("IEN")=RMPRI
  1.  .. S RMPR11U("ITEM MASTER IEN")=RMPR11("ITEM MASTER IEN")
  1.  .. S RMPRERR=$$UPD^RMPRPIX1(.RMPR11U)
  1.  .. S RMPRGOT=1
  1.  .. Q
  1.  . Q
  1.  I RMPRGOT S RMPR11("ITEM")=RMPRITM G GETITMX
  1.  S RMPR11("ITEM")="" ; ensure new item will be created
  1. GETITM1 S RMPRS=$G(^RMPR(661.1,RMPRHIEN,3,RMPRITM,0))
  1.  S RMPR11("DESCRIPTION")=$P(RMPRS,"^",1)
  1.  S:RMPR11("DESCRIPTION")="" RMPR11("DESCRIPTION")="NO DESCRIPTION"
  1.  S RMPRERR=$$CRE^RMPRPIX1(.RMPR11)
  1.  ;
  1.  ; map new HCPCS Item in 661.11 to old iens in 661.1
  1.  S RMPRS=""
  1.  S $P(RMPRS,"^",1)=RMPR11("STATION")
  1.  S $P(RMPRS,"^",2)=RMPR11("HCPCS")
  1.  S $P(RMPRS,"^",3)=RMPR11("ITEM")
  1.  S $P(RMPRS,"^",4)=RMPR11("IEN")
  1.  S ^TMP($J,"ITEM",RMPRHIEN,RMPRITM,RMPR11("SOURCE"),RMPRIM)=RMPRS
  1. GETITMX Q