RMPR29W1 ;HOIFO/SPS - WORK ORDER ADD ON GRID OWL PROGRAM ;11/8/05 07:12
;;3.0;PROSTHETICS;**75**;Feb 09, 1996;Build 25
;
;
A1(RMPR6641) ;entry point for testing
D A2
Q
EN(RESULT,RMPR6641) ; -- Broker callback to get list to display
A2 N STRING,CLREND,COLUMN,ON,OFF
S DATE=2010101
K ^TMP($J)
N RMPRA,CDATE,X
K ADATE,PDAY,RMPRCD
S (CNT,VALMCNT)=0,RRX=""
;S (PPDAY,PPD,PPD1,PPD2,PPD3,PPD4,PPD5)=0
;S (PPDDAY,PPDD1,PPDD2,PPDD3,PPDD4,PPDD5)=0
I '$D(^RMPR(664.1,RMPR6641,0)) Q
I $P(^RMPR(664.1,RMPR6641,0),U,13)="" Q
S WO66410=^RMPR(664.1,RMPR6641,0)
;W !!,RMPR6641," ",WO66410
S RMPRA=$P(WO66410,U,8) Q:RMPRA'>0 D
.S STN=$P(^RMPR(668,RMPRA,0),U,7)
.S STNX=$$STATN^RMPRUTIL(STN)
.S STS=$P(^RMPR(668,RMPRA,0),U,10)
.;Q:STS'["P"
.S DFN=$P(^RMPR(668,RMPRA,0),U,2)
.D DEM^VADPT
.S SSNEN=$E($P(VADM(2),"^",2),10,11)
.K SSNEN,VADM
.D REC
G EXIT
Q
K CDAY,DNT,DATE,DFN,LINKED,PPD,PPDAY,RMPRAON,RMPRHCSN,RMPRII,RMPRMI
K RMPRPCE,RMPRPCI,RMPRPHCE,RMPRPHCI,RMPRTC,RMPRTTE,RMPRTTI,RMPRUI
K RMPRUIE,RRX,STN,STNX,STS,VALMCNT,WO66410,WRKDAY
REC ;records to grid
;stop date, init action date
;check ien, patch 77
;
;Q:$D(^TMP($J,RMPRA))
;
N DIC,DIQ,DR,STOPDT
;S DA=RMPRA
;S DIC=668,DIQ="RE",DR=10,DIQ(0)="EN" D EN^DIQ1
S STOPDT=$P($G(^RMPR(668,RMPRA,0)),U,9),STOPDT=$$DAT2^RMPRUTL1(STOPDT)
S CDATE=$P(^RMPR(668,RMPRA,0),U,1),CDATE=$$DAT2^RMPRUTL1(CDATE)
S DFN=$P(^RMPR(668,RMPRA,0),U,2) Q:DFN=""
N VA,VADM
D DEM^VADPT
S WHO=VADM(1)
S SSN=VADM(2)
D KVAR^VADPT
;type
S TYPE=$$TYPE^RMPREOU(RMPRA,8)
Q:TYPE'["LAB"
;W !,"AFTER",RMPRA," ",WO66410
;display description if manual
S DES=$$DES^RMPREOU(RMPRA,22)
S DES=$TR(DES,"^","*")
S DES=$TR(DES,"""","'")
;init action date
S ADATE="",PDAY="",WRKDAY=""
S ADATE=$P(^RMPR(668,RMPRA,0),U,9)
;PPD=1 for previous pending
I ADATE'="" S CDAY=$$PDAY^RMPREOU(RMPRA)
;
S STATUS=$$STATUS^RMPREOU(RMPRA)
I STATUS["PENDING" D
.I ADATE'=""&(ADATE<DATE) S PPD=1
.S PPDAY=$$PWRKDAY^RMPREOU(RMPRA)
S LINKED=$P($G(^RMPR(668,RMPRA,10,0)),U,4)
I LINKED="" S LINKED=0
;
;Get Work Order Data and add to array
S RMPRAON="" F S RMPRAON=$O(^RMPR(664.1,RMPR6641,2,RMPRAON)) Q:RMPRAON="" D
. Q:'$D(^RMPR(664.1,RMPR6641,2,RMPRAON,0))
. ;Change to send only item 1
. ;Q:RMPRAON>1
. S CNT=CNT+1
. S RMPRII=^RMPR(664.1,RMPR6641,2,RMPRAON,0)
. ;S RMPR6642=$P(RMPRII,U,6)
. ;Internal and external item
. ;S RMPRSOI=$P(RMPRII,U),RMPRSOIE=$$EXTERNAL^DILFD(664.16,.01,"",RMPRSOI)
. ;Chose to display 661.1 short description instead. left for PFU.
. ;Internal/external unit of issue
. S RMPRUI=$P(RMPRII,U,3),RMPRUIE=$$EXTERNAL^DILFD(664.16,3,"",RMPRUI)
. ;Internal/external Type of Transaction
. S RMPRTTI=$P(RMPRII,U,7),RMPRTTE=$$EXTERNAL^DILFD(664.16,8,"",RMPRTTI)
. ;Internal/external patient category
. S RMPRPCI=$P(RMPRII,U,8),RMPRPCE=$$EXTERNAL^DILFD(664.16,9,"",RMPRPCI)
. ;Internal/External HCPCS
. S RMPRPHCI=$P($G(^RMPR(664.1,RMPR6641,2,RMPRAON,2)),U,1),RMPRPHCE=$$EXTERNAL^DILFD(661.1,1,"",RMPRPHCI)
. ;HCPCS SHORT NAME
. I +RMPRPHCI>0 S RMPRHCSN=$P($G(^RMPR(661.1,RMPRPHCI,0)),U,2)
. E S RMPRHCSN="UNKNOWN HCPCS NAME"
. ;Internal/External CPT Modifier
. S RMPRMI=$P($G(^RMPR(664.1,RMPR6641,2,RMPRAON,2)),U,2)
. S RMPRTC=$P(RMPRII,U,11)
. S ^TMP($J,RMPRA,CNT)=0_U_RMPRAON_U_RMPRHCSN_U_$P(RMPRII,U,2)_U_RMPRUIE_U_$P(RMPRII,U,4)_U_$P(RMPRII,U,5)
. S ^TMP($J,RMPRA,CNT)=^TMP($J,RMPRA,CNT)_U_$P(RMPRII,U,6)_U_RMPRTTE_U_RMPRPCE
. S ^TMP($J,RMPRA,CNT)=^TMP($J,RMPRA,CNT)_U_RMPRPHCE_U_RMPRMI_U_RMPRTC
K CDATE,WHO,SSN,TYPE,DES,PDAY,STATUS,ADATE
;PUT RESULTS IN GLOBAL!!
Q
EXIT ;common exit point
S RESULT=$NA(^TMP($J))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR29W1 3725 printed Apr 09, 2024@21:38:44 Page 2
RMPR29W1 ;HOIFO/SPS - WORK ORDER ADD ON GRID OWL PROGRAM ;11/8/05 07:12
+1 ;;3.0;PROSTHETICS;**75**;Feb 09, 1996;Build 25
+2 ;
+3 ;
A1(RMPR6641) ;entry point for testing
+1 DO A2
+2 QUIT
EN(RESULT,RMPR6641) ; -- Broker callback to get list to display
A2 NEW STRING,CLREND,COLUMN,ON,OFF
+1 SET DATE=2010101
+2 KILL ^TMP($JOB)
+3 NEW RMPRA,CDATE,X
+4 KILL ADATE,PDAY,RMPRCD
+5 SET (CNT,VALMCNT)=0
SET RRX=""
+6 ;S (PPDAY,PPD,PPD1,PPD2,PPD3,PPD4,PPD5)=0
+7 ;S (PPDDAY,PPDD1,PPDD2,PPDD3,PPDD4,PPDD5)=0
+8 IF '$DATA(^RMPR(664.1,RMPR6641,0))
QUIT
+9 IF $PIECE(^RMPR(664.1,RMPR6641,0),U,13)=""
QUIT
+10 SET WO66410=^RMPR(664.1,RMPR6641,0)
+11 ;W !!,RMPR6641," ",WO66410
+12 SET RMPRA=$PIECE(WO66410,U,8)
if RMPRA'>0
QUIT
Begin DoDot:1
+13 SET STN=$PIECE(^RMPR(668,RMPRA,0),U,7)
+14 SET STNX=$$STATN^RMPRUTIL(STN)
+15 SET STS=$PIECE(^RMPR(668,RMPRA,0),U,10)
+16 ;Q:STS'["P"
+17 SET DFN=$PIECE(^RMPR(668,RMPRA,0),U,2)
+18 DO DEM^VADPT
+19 SET SSNEN=$EXTRACT($PIECE(VADM(2),"^",2),10,11)
+20 KILL SSNEN,VADM
+21 DO REC
End DoDot:1
+22 GOTO EXIT
+23 QUIT
+24 KILL CDAY,DNT,DATE,DFN,LINKED,PPD,PPDAY,RMPRAON,RMPRHCSN,RMPRII,RMPRMI
+25 KILL RMPRPCE,RMPRPCI,RMPRPHCE,RMPRPHCI,RMPRTC,RMPRTTE,RMPRTTI,RMPRUI
+26 KILL RMPRUIE,RRX,STN,STNX,STS,VALMCNT,WO66410,WRKDAY
REC ;records to grid
+1 ;stop date, init action date
+2 ;check ien, patch 77
+3 ;
+4 ;Q:$D(^TMP($J,RMPRA))
+5 ;
+6 NEW DIC,DIQ,DR,STOPDT
+7 ;S DA=RMPRA
+8 ;S DIC=668,DIQ="RE",DR=10,DIQ(0)="EN" D EN^DIQ1
+9 SET STOPDT=$PIECE($GET(^RMPR(668,RMPRA,0)),U,9)
SET STOPDT=$$DAT2^RMPRUTL1(STOPDT)
+10 SET CDATE=$PIECE(^RMPR(668,RMPRA,0),U,1)
SET CDATE=$$DAT2^RMPRUTL1(CDATE)
+11 SET DFN=$PIECE(^RMPR(668,RMPRA,0),U,2)
if DFN=""
QUIT
+12 NEW VA,VADM
+13 DO DEM^VADPT
+14 SET WHO=VADM(1)
+15 SET SSN=VADM(2)
+16 DO KVAR^VADPT
+17 ;type
+18 SET TYPE=$$TYPE^RMPREOU(RMPRA,8)
+19 if TYPE'["LAB"
QUIT
+20 ;W !,"AFTER",RMPRA," ",WO66410
+21 ;display description if manual
+22 SET DES=$$DES^RMPREOU(RMPRA,22)
+23 SET DES=$TRANSLATE(DES,"^","*")
+24 SET DES=$TRANSLATE(DES,"""","'")
+25 ;init action date
+26 SET ADATE=""
SET PDAY=""
SET WRKDAY=""
+27 SET ADATE=$PIECE(^RMPR(668,RMPRA,0),U,9)
+28 ;PPD=1 for previous pending
+29 IF ADATE'=""
SET CDAY=$$PDAY^RMPREOU(RMPRA)
+30 ;
+31 SET STATUS=$$STATUS^RMPREOU(RMPRA)
+32 IF STATUS["PENDING"
Begin DoDot:1
+33 IF ADATE'=""&(ADATE<DATE)
SET PPD=1
+34 SET PPDAY=$$PWRKDAY^RMPREOU(RMPRA)
End DoDot:1
+35 SET LINKED=$PIECE($GET(^RMPR(668,RMPRA,10,0)),U,4)
+36 IF LINKED=""
SET LINKED=0
+37 ;
+38 ;Get Work Order Data and add to array
+39 SET RMPRAON=""
FOR
SET RMPRAON=$ORDER(^RMPR(664.1,RMPR6641,2,RMPRAON))
if RMPRAON=""
QUIT
Begin DoDot:1
+40 if '$DATA(^RMPR(664.1,RMPR6641,2,RMPRAON,0))
QUIT
+41 ;Change to send only item 1
+42 ;Q:RMPRAON>1
+43 SET CNT=CNT+1
+44 SET RMPRII=^RMPR(664.1,RMPR6641,2,RMPRAON,0)
+45 ;S RMPR6642=$P(RMPRII,U,6)
+46 ;Internal and external item
+47 ;S RMPRSOI=$P(RMPRII,U),RMPRSOIE=$$EXTERNAL^DILFD(664.16,.01,"",RMPRSOI)
+48 ;Chose to display 661.1 short description instead. left for PFU.
+49 ;Internal/external unit of issue
+50 SET RMPRUI=$PIECE(RMPRII,U,3)
SET RMPRUIE=$$EXTERNAL^DILFD(664.16,3,"",RMPRUI)
+51 ;Internal/external Type of Transaction
+52 SET RMPRTTI=$PIECE(RMPRII,U,7)
SET RMPRTTE=$$EXTERNAL^DILFD(664.16,8,"",RMPRTTI)
+53 ;Internal/external patient category
+54 SET RMPRPCI=$PIECE(RMPRII,U,8)
SET RMPRPCE=$$EXTERNAL^DILFD(664.16,9,"",RMPRPCI)
+55 ;Internal/External HCPCS
+56 SET RMPRPHCI=$PIECE($GET(^RMPR(664.1,RMPR6641,2,RMPRAON,2)),U,1)
SET RMPRPHCE=$$EXTERNAL^DILFD(661.1,1,"",RMPRPHCI)
+57 ;HCPCS SHORT NAME
+58 IF +RMPRPHCI>0
SET RMPRHCSN=$PIECE($GET(^RMPR(661.1,RMPRPHCI,0)),U,2)
+59 IF '$TEST
SET RMPRHCSN="UNKNOWN HCPCS NAME"
+60 ;Internal/External CPT Modifier
+61 SET RMPRMI=$PIECE($GET(^RMPR(664.1,RMPR6641,2,RMPRAON,2)),U,2)
+62 SET RMPRTC=$PIECE(RMPRII,U,11)
+63 SET ^TMP($JOB,RMPRA,CNT)=0_U_RMPRAON_U_RMPRHCSN_U_$PIECE(RMPRII,U,2)_U_RMPRUIE_U_$PIECE(RMPRII,U,4)_U_$PIECE(RMPRII,U,5)
+64 SET ^TMP($JOB,RMPRA,CNT)=^TMP($JOB,RMPRA,CNT)_U_$PIECE(RMPRII,U,6)_U_RMPRTTE_U_RMPRPCE
+65 SET ^TMP($JOB,RMPRA,CNT)=^TMP($JOB,RMPRA,CNT)_U_RMPRPHCE_U_RMPRMI_U_RMPRTC
End DoDot:1
+66 KILL CDATE,WHO,SSN,TYPE,DES,PDAY,STATUS,ADATE
+67 ;PUT RESULTS IN GLOBAL!!
+68 QUIT
EXIT ;common exit point
+1 SET RESULT=$NAME(^TMP($JOB))
+2 QUIT
