RMPRDDC ;VACO/HNC - SERVER ROUTINE FOR DALC RECORD IN 660 ; 11/01/2006
;;3.0;PROSTHETICS;**60,141**;Feb 09, 1996;Build 5
;Per VHA Directive 10-93-142, this routine should not be modified.
;
;DBIA # 10072 - for routine REMSBMSG^XMA1C
;DBIA # ????? - for D FIND^DIC(2,,".09"
;
MAIN ;main entry point
;loop msg
K RMPRMSG
N ERR
S RMPRCNT=0
S RMPRMSGC=0
F X XMREC Q:XMRG="" D
.S RMPRDATA=XMRG
.Q:RMPRDATA="ENCRYPTED STRING"
.S (RMPRTD,RMPRMPI,RMPRSSN,RMPRNAM,RMPRTRAN,RMPRCAT,RMPRPP,RMPRICD,RMPRITM,RMPRHCPE,RMPRHCP,RMPRSTN,RMPRCMT,RMPRCOST,RMPRQTY,RMPRREF,RMPRSRL,RMPRVND,RMPRDUN,RMPRTAX,RMPRRT,DFN)=""
.;parse data string
.S RMPRNPMN=$P(XQSUB,"#",2)
.S RMPRMSGC=RMPRMSGC+1
.S RMPRCNT=RMPRCNT+1
.S RMPRFLG=$P($G(RMPRDATA),U,21) ;retransmission flag Y or N
.S X=$P($P($G(RMPRDATA),U,1),".",1) ;transaction date
.S X=$E(X,5,6)_"/"_$E(X,7,8)_"/"_$E(X,3,4) D ^%DT S RMPRTD=Y
.I RMPRTD=-1 S RMPRTD=""
.S RMPRMPI=$P($G(RMPRDATA),U,2) ;MPI
.S RMPRSSN=$P($G(RMPRDATA),U,3) ;SSN
.S RMPRPNAM=$P($G(RMPRDATA),U,4) ;Patient Name
.S RMPRTRAN=$P($G(RMPRDATA),U,5) ;Type New or Repair
.I RMPRTRAN="N" S RMPRTRAN="I" ;new trans
.I RMPRTRAN="R" S RMPRTRAN="X" ;repair trans
.S RMPRCAT=$P($G(RMPRDATA),U,6) ;category NSC or SC
.I RMPRCAT="NSC" S RMPRCAT=4
.I RMPRCAT="SC" S RMPRCAT=1
.S RMPRPP=$P($G(RMPRDATA),U,7) ;Person placing order DALC STAFF or VET
.S RMPRICD=$P($G(RMPRDATA),U,8) ;ICD9 blank for now
.S RMPRITM=$P($G(RMPRDATA),U,9) ;Item HCPCS short desc
.S RMPRHCPE=$P($G(RMPRDATA),U,10) ;hcpcs
.S RMPRHCP=""
.S RMPRHCP=$O(^RMPR(661.1,"B",RMPRHCPE,RMPRHCP))
.I RMPRHCP="" S RMPRITM=RMPRITM_" *NOT VALID"
.S RMPRSTN=$P($G(RMPRDATA),U,11) ;station billing number
.S RMPRCMT=$P($G(RMPRDATA),U,12) ;comment
.S RMPRCOST=$P($G(RMPRDATA),U,13) ;total cost
.S RMPRQTY=$P($G(RMPRDATA),U,14) ;qty
.S RMPRREF=$P($G(RMPRDATA),U,15) ;ddc internal reference
.S RMPRSRL=$P($G(RMPRDATA),U,16) ;serial number
.S RMPRVND=$P($G(RMPRDATA),U,17) ;vendor as text
.S RMPRDUN=$P($G(RMPRDATA),U,18) ;dun
.S RMPRTAX=$P($G(RMPRDATA),U,19) ;tax
.; RMPRDAT,U,21 IS RESERVED FOR A RETURN NUMBER TBD SKIPPED
.S RMPROS=$P($G(RMPRDATA),U,22) ;ordering station
.S RMPRSTA=$$FIND1^DIC(4,"","X",RMPROS,"D","","ERR")
.I $D(ERR)!(RMPRSTA'>0) D
.. S RMPR6699=$O(^RMPR(669.9,0)),RMPRSTA=$P(^RMPR(669.9,RMPR6699,0),U,2)
.S X=$P($G(RMPRDATA),U,20) ;return date
.S X=$E(X,5,6)_"/"_$E(X,7,8)_"/"_$E(X,3,4) D ^%DT S RMPRRT=Y
.I RMPRRT=-1 S RMPRRT=""
.;file
.D NOW^%DTC S RMPRWHN=$P(%,".",1)
.;check to see if new
.I $D(^RMPR(660,"DDC",RMPRREF)) S RMPRMSG(RMPRMSGC)="Record already on file, Not Processed: "_RMPRREF Q
.;find patient
.D FIND^DIC(2,,".09","PS",RMPRSSN,3,"SSN","","","RMPROUT")
.I '$G(RMPROUT("DILIST","1",0)) S RMPRMSG(RMPRMSGC)="Patient Not Found Not Processed: "_RMPRREF Q
.I $G(RMPROUT("DISLIST",2,0)) S RMPRMSG(RMPRMSGC)="More than one Patient with Same SSN, Patient Not Processed: "_RMPRREF Q ;more than one with same ssn
.S DFN=$P(RMPROUT("DILIST",1,0),U,1)
.;check 665 if not there add it
.;array to file
.K RMPRERR,RMPR660
.S RMPR660(660,"+1,",.01)=RMPRWHN
.S RMPR660(660,"+1,",.02)=DFN
.S RMPR660(660,"+1,",1)=RMPRTD
.S RMPR660(660,"+1,",89.2)=RMPRTD
.S RMPR660(660,"+1,",2)=RMPRTRAN
.S RMPR660(660,"+1,",4.2)=RMPRPP
.S RMPR660(660,"+1,",62)=RMPRCAT
.S RMPR660(660,"+1,",89)=RMPRITM
.S RMPR660(660,"+1,",24)=RMPRITM
.S RMPR660(660,"+1,",16)=RMPRCMT
.S RMPR660(660,"+1,",14)=RMPRCOST
.S RMPR660(660,"+1,",5)=RMPRQTY
.S RMPR660(660,"+1,",9)=RMPRSRL
.S RMPR660(660,"+1,",91)=RMPRVND
.S RMPR660(660,"+1,",92)=RMPRDUN
.S RMPR660(660,"+1,",93)=RMPRTAX
.S RMPR660(660,"+1,",17.5)=RMPRRT
.S RMPR660(660,"+1,",17)=1
.S RMPR660(660,"+1,",89.3)=RMPROS
.S RMPR660(660,"+1,",90)=RMPRSTN
.S RMPR660(660,"+1,",4.5)=RMPRHCP
.S RMPR660(660,"+1,",89.1)=RMPRREF
.S RMPR660(660,"+1,",11)=16
.S RMPR660(660,"+1,",12)="V" ;source
.S RMPR660(660,"+1,",15)="*" ;historical data flag
.D UPDATE^DIE("","RMPR660","","RMPRERR")
.I $D(RMPRERR) D
. .S RMPRMSG(RMPRMSGC)=$G(RMPRERR("DIERR","1","TEXT",1))_"Error Not Processed: "_RMPRREF
. .;S RMPRMSG(RMPRMSGC)="Error Not Processed: "_RMPRREF
. .S XMY("G.RMPR SERVER")=""
.S RMPRMSG(RMPRMSGC)="Done: "_RMPRREF
;Send email to ddc with number of records processed
S XMDUZ=.5
S XMY("G.RMPR SERVER")=""
S XMY("S.RMPRACKDALC@DDC.DOMAIN.EXT")=""
S XMSUB="Prosthetics - DALC Interface Summary NPNM #"_RMPRNPMN
S RMPRMSGC=RMPRMSGC+1
S RMPRMSG(RMPRMSGC)="Total Records Received: "_RMPRCNT
S XMTEXT="RMPRMSG("
D ^XMD
;
EXIT ;main exit point
K RMPRTD,RMPRMPI,RMPRSSN,RMPRNAM,RMPRTRAN,RMPRCAT,RMPRPP,RMPRICD
K RMPRITM,RMPRHCPE,RMPRHCP,RMPRSTN,RMPRCMT,RMPRCOST,RMPRQTY,RMPRREF
K RMPRSRL,RMPRVND,RMPRDUN,RMPRTAX,RMPRRT,DFN,RMPR(660),RMPRCNT,RMPRDATA
K RMPRFLG,RMPROUT,RMPRNAM,RMPRWHN,RMPRMSGC,RMPRPNAM,RMPRNPMN,RMPRSTA,RMPR6699
;purge server message
S XMSER="S."_XQSOP,XMZ=XQMSG D REMSBMSG^XMA1C
Q
;END
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRDDC 5042 printed Sep 23, 2025@20:10:19 Page 2
RMPRDDC ;VACO/HNC - SERVER ROUTINE FOR DALC RECORD IN 660 ; 11/01/2006
+1 ;;3.0;PROSTHETICS;**60,141**;Feb 09, 1996;Build 5
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;DBIA # 10072 - for routine REMSBMSG^XMA1C
+5 ;DBIA # ????? - for D FIND^DIC(2,,".09"
+6 ;
MAIN ;main entry point
+1 ;loop msg
+2 KILL RMPRMSG
+3 NEW ERR
+4 SET RMPRCNT=0
+5 SET RMPRMSGC=0
+6 FOR
XECUTE XMREC
if XMRG=""
QUIT
Begin DoDot:1
+7 SET RMPRDATA=XMRG
+8 if RMPRDATA="ENCRYPTED STRING"
QUIT
+9 SET (RMPRTD,RMPRMPI,RMPRSSN,RMPRNAM,RMPRTRAN,RMPRCAT,RMPRPP,RMPRICD,RMPRITM,RMPRHCPE,RMPRHCP,RMPRSTN,RMPRCMT,RMPRCOST,RMPRQTY,RMPRREF,RMPRSRL,RMPRVND,RMPRDUN,RMPRTAX,RMPRRT,DFN)=""
+10 ;parse data string
+11 SET RMPRNPMN=$PIECE(XQSUB,"#",2)
+12 SET RMPRMSGC=RMPRMSGC+1
+13 SET RMPRCNT=RMPRCNT+1
+14 ;retransmission flag Y or N
SET RMPRFLG=$PIECE($GET(RMPRDATA),U,21)
+15 ;transaction date
SET X=$PIECE($PIECE($GET(RMPRDATA),U,1),".",1)
+16 SET X=$EXTRACT(X,5,6)_"/"_$EXTRACT(X,7,8)_"/"_$EXTRACT(X,3,4)
DO ^%DT
SET RMPRTD=Y
+17 IF RMPRTD=-1
SET RMPRTD=""
+18 ;MPI
SET RMPRMPI=$PIECE($GET(RMPRDATA),U,2)
+19 ;SSN
SET RMPRSSN=$PIECE($GET(RMPRDATA),U,3)
+20 ;Patient Name
SET RMPRPNAM=$PIECE($GET(RMPRDATA),U,4)
+21 ;Type New or Repair
SET RMPRTRAN=$PIECE($GET(RMPRDATA),U,5)
+22 ;new trans
IF RMPRTRAN="N"
SET RMPRTRAN="I"
+23 ;repair trans
IF RMPRTRAN="R"
SET RMPRTRAN="X"
+24 ;category NSC or SC
SET RMPRCAT=$PIECE($GET(RMPRDATA),U,6)
+25 IF RMPRCAT="NSC"
SET RMPRCAT=4
+26 IF RMPRCAT="SC"
SET RMPRCAT=1
+27 ;Person placing order DALC STAFF or VET
SET RMPRPP=$PIECE($GET(RMPRDATA),U,7)
+28 ;ICD9 blank for now
SET RMPRICD=$PIECE($GET(RMPRDATA),U,8)
+29 ;Item HCPCS short desc
SET RMPRITM=$PIECE($GET(RMPRDATA),U,9)
+30 ;hcpcs
SET RMPRHCPE=$PIECE($GET(RMPRDATA),U,10)
+31 SET RMPRHCP=""
+32 SET RMPRHCP=$ORDER(^RMPR(661.1,"B",RMPRHCPE,RMPRHCP))
+33 IF RMPRHCP=""
SET RMPRITM=RMPRITM_" *NOT VALID"
+34 ;station billing number
SET RMPRSTN=$PIECE($GET(RMPRDATA),U,11)
+35 ;comment
SET RMPRCMT=$PIECE($GET(RMPRDATA),U,12)
+36 ;total cost
SET RMPRCOST=$PIECE($GET(RMPRDATA),U,13)
+37 ;qty
SET RMPRQTY=$PIECE($GET(RMPRDATA),U,14)
+38 ;ddc internal reference
SET RMPRREF=$PIECE($GET(RMPRDATA),U,15)
+39 ;serial number
SET RMPRSRL=$PIECE($GET(RMPRDATA),U,16)
+40 ;vendor as text
SET RMPRVND=$PIECE($GET(RMPRDATA),U,17)
+41 ;dun
SET RMPRDUN=$PIECE($GET(RMPRDATA),U,18)
+42 ;tax
SET RMPRTAX=$PIECE($GET(RMPRDATA),U,19)
+43 ; RMPRDAT,U,21 IS RESERVED FOR A RETURN NUMBER TBD SKIPPED
+44 ;ordering station
SET RMPROS=$PIECE($GET(RMPRDATA),U,22)
+45 SET RMPRSTA=$$FIND1^DIC(4,"","X",RMPROS,"D","","ERR")
+46 IF $DATA(ERR)!(RMPRSTA'>0)
Begin DoDot:2
+47 SET RMPR6699=$ORDER(^RMPR(669.9,0))
SET RMPRSTA=$PIECE(^RMPR(669.9,RMPR6699,0),U,2)
End DoDot:2
+48 ;return date
SET X=$PIECE($GET(RMPRDATA),U,20)
+49 SET X=$EXTRACT(X,5,6)_"/"_$EXTRACT(X,7,8)_"/"_$EXTRACT(X,3,4)
DO ^%DT
SET RMPRRT=Y
+50 IF RMPRRT=-1
SET RMPRRT=""
+51 ;file
+52 DO NOW^%DTC
SET RMPRWHN=$PIECE(%,".",1)
+53 ;check to see if new
+54 IF $DATA(^RMPR(660,"DDC",RMPRREF))
SET RMPRMSG(RMPRMSGC)="Record already on file, Not Processed: "_RMPRREF
QUIT
+55 ;find patient
+56 DO FIND^DIC(2,,".09","PS",RMPRSSN,3,"SSN","","","RMPROUT")
+57 IF '$GET(RMPROUT("DILIST","1",0))
SET RMPRMSG(RMPRMSGC)="Patient Not Found Not Processed: "_RMPRREF
QUIT
+58 ;more than one with same ssn
IF $GET(RMPROUT("DISLIST",2,0))
SET RMPRMSG(RMPRMSGC)="More than one Patient with Same SSN, Patient Not Processed: "_RMPRREF
QUIT
+59 SET DFN=$PIECE(RMPROUT("DILIST",1,0),U,1)
+60 ;check 665 if not there add it
+61 ;array to file
+62 KILL RMPRERR,RMPR660
+63 SET RMPR660(660,"+1,",.01)=RMPRWHN
+64 SET RMPR660(660,"+1,",.02)=DFN
+65 SET RMPR660(660,"+1,",1)=RMPRTD
+66 SET RMPR660(660,"+1,",89.2)=RMPRTD
+67 SET RMPR660(660,"+1,",2)=RMPRTRAN
+68 SET RMPR660(660,"+1,",4.2)=RMPRPP
+69 SET RMPR660(660,"+1,",62)=RMPRCAT
+70 SET RMPR660(660,"+1,",89)=RMPRITM
+71 SET RMPR660(660,"+1,",24)=RMPRITM
+72 SET RMPR660(660,"+1,",16)=RMPRCMT
+73 SET RMPR660(660,"+1,",14)=RMPRCOST
+74 SET RMPR660(660,"+1,",5)=RMPRQTY
+75 SET RMPR660(660,"+1,",9)=RMPRSRL
+76 SET RMPR660(660,"+1,",91)=RMPRVND
+77 SET RMPR660(660,"+1,",92)=RMPRDUN
+78 SET RMPR660(660,"+1,",93)=RMPRTAX
+79 SET RMPR660(660,"+1,",17.5)=RMPRRT
+80 SET RMPR660(660,"+1,",17)=1
+81 SET RMPR660(660,"+1,",89.3)=RMPROS
+82 SET RMPR660(660,"+1,",90)=RMPRSTN
+83 SET RMPR660(660,"+1,",4.5)=RMPRHCP
+84 SET RMPR660(660,"+1,",89.1)=RMPRREF
+85 SET RMPR660(660,"+1,",11)=16
+86 ;source
SET RMPR660(660,"+1,",12)="V"
+87 ;historical data flag
SET RMPR660(660,"+1,",15)="*"
+88 DO UPDATE^DIE("","RMPR660","","RMPRERR")
+89 IF $DATA(RMPRERR)
Begin DoDot:2
+90 SET RMPRMSG(RMPRMSGC)=$GET(RMPRERR("DIERR","1","TEXT",1))_"Error Not Processed: "_RMPRREF
+91 ;S RMPRMSG(RMPRMSGC)="Error Not Processed: "_RMPRREF
+92 SET XMY("G.RMPR SERVER")=""
End DoDot:2
+93 SET RMPRMSG(RMPRMSGC)="Done: "_RMPRREF
End DoDot:1
+94 ;Send email to ddc with number of records processed
+95 SET XMDUZ=.5
+96 SET XMY("G.RMPR SERVER")=""
+97 SET XMY("S.RMPRACKDALC@DDC.DOMAIN.EXT")=""
+98 SET XMSUB="Prosthetics - DALC Interface Summary NPNM #"_RMPRNPMN
+99 SET RMPRMSGC=RMPRMSGC+1
+100 SET RMPRMSG(RMPRMSGC)="Total Records Received: "_RMPRCNT
+101 SET XMTEXT="RMPRMSG("
+102 DO ^XMD
+103 ;
EXIT ;main exit point
+1 KILL RMPRTD,RMPRMPI,RMPRSSN,RMPRNAM,RMPRTRAN,RMPRCAT,RMPRPP,RMPRICD
+2 KILL RMPRITM,RMPRHCPE,RMPRHCP,RMPRSTN,RMPRCMT,RMPRCOST,RMPRQTY,RMPRREF
+3 KILL RMPRSRL,RMPRVND,RMPRDUN,RMPRTAX,RMPRRT,DFN,RMPR(660),RMPRCNT,RMPRDATA
+4 KILL RMPRFLG,RMPROUT,RMPRNAM,RMPRWHN,RMPRMSGC,RMPRPNAM,RMPRNPMN,RMPRSTA,RMPR6699
+5 ;purge server message
+6 SET XMSER="S."_XQSOP
SET XMZ=XQMSG
DO REMSBMSG^XMA1C
+7 QUIT
+8 ;END
