RMPVS633 ; OIT/JDA - SCAMP runtime support; Nov 17, 2024@23:35:37
;;1.0;PROSTHETICS VISION 4 SIGHT II;**2**;Jan 31, 2025;Build 38
;
; Reference to file #668 supported by ICR #6540
; Reference to file #665 supported by ICR #6537
; Reference to file #2 (^DPT) supported by ICR #7019
;
Q
TEST ;test tag
;TSTART
N REQ,RESP
S REQ("consult_ien")=1396535
S REQ("patient_ssn")=557635084
S REQ("barcode_key")="V2100-3240916104909"
D RUN(.REQ,.RESP)
u $P
;zw RESP
Q
TEST2 ;test tag
;TSTART
N REQ,RESP
S REQ("consult_ien")=1397538
S REQ("patient_ssn")=614659908
S REQ("barcode_key")="A9300-324121253536"
D RUN(.REQ,.RESP)
U $P
;zw RESP
Q
TEST3 ;test tag
;TSTART
N REQ,RESP
S REQ("consult_ien")=282223
S REQ("patient_ssn")=571366114
S REQ("barcode_key")="A4500-3190723101447"
S REQ("inventory_location")="4SIGHTTEST"
S REQ("hcpcs")="A4500"
S REQ("type_of_transaction")="S"
S REQ("issue_date")="Dec 17, 2024"
S REQ("quantity")=1
S REQ("remarks")="none"
D RUN(.REQ,.RESP)
U $P
;zw RESP
Q
;
TEST4 ; test tag for multiples
;
N ARY,I,REQUEST
;
S ARY(1,"consult_ien")=1036763
S ARY(1,"patient_ssn")="032794208"
S ARY(1,"barcode_key")="A4565-3250219164758"
S ARY(1,"inventory_location")="4SIGHTTEST"
S ARY(1,"hcpcs")="A4565"
S ARY(1,"type_of_transaction")="S"
S ARY(1,"issue_date")="Feb 19, 2025"
S ARY(1,"quantity")=1
S ARY(1,"remarks")="none"
;
S ARY(2,"consult_ien")=1036764
S ARY(2,"patient_ssn")="112044625"
S ARY(2,"barcode_key")="A4565-3250219164758"
S ARY(2,"inventory_location")="4SIGHTTEST"
S ARY(2,"hcpcs")="A4565"
S ARY(2,"type_of_transaction")="S"
S ARY(2,"issue_date")="Feb 19, 2025"
S ARY(2,"quantity")=1
S ARY(2,"remarks")="none"
;
S ARY(3,"consult_ien")=1036778
S ARY(3,"patient_ssn")="012397949"
S ARY(3,"barcode_key")="A4565-3250219164758"
S ARY(3,"inventory_location")="4SIGHTTEST"
S ARY(3,"hcpcs")="A4565"
S ARY(3,"type_of_transaction")="S"
S ARY(3,"issue_date")="Feb 19, 2025"
S ARY(3,"quantity")=1
S ARY(3,"remarks")="none"
;
F I=1:1:3 D
. N RESP,REQUEST
. M REQUEST=ARY(I)
. D RUN(.REQUEST,.RESP)
. ;ZW RESP
. Q
Q
;
RUN(REQUEST,RESPONSE) ; set up input/output vars and run
N $ESTACK,$ETRAP S $ETRAP="D ETRAP^RMPVS633"
K ^TMP($J,"RMPV")
N DFN S DFN=$O(^DPT("SSN",REQUEST("patient_ssn"),""))
I 'DFN D Q
.D ERROR("Could not locate a patient with a matching SSN.")
.M RESPONSE=^TMP($J,"RMPV","OUT")
N SUSP S SUSP=$$FINDSUSP(DFN,REQUEST("consult_ien"))
I 'SUSP D Q
.D ERROR("Suspense record in desired status not found.")
.M RESPONSE=^TMP($J,"RMPV","OUT")
I '$$DISCHK(.REQUEST) D Q
. D ERROR("Failed to update; patient missing disability code.")
. S ^TMP($J,"RMPV","OUT","consult_ien")=REQUEST("consult_ien")
. M RESPONSE=^TMP($J,"RMPV","OUT")
. Q
S ^TMP($J,"RMPV","OUT","http_response","http_status_code")=200
S ^TMP($J,"RMPV","OUT","http_response","message")=""
S ^TMP($J,"RMPV","OUT","suspense_ien")=SUSP
S ^TMP($J,"RMPV","OUT","consult_ien")=REQUEST("consult_ien")
D LOADVARS(.REQUEST)
;
D
.D RUN^RMPVDRV("EN7^RMPV0RMPROP",$T(+0))
I $$ISERROR K ^TMP($J,"RMPV","OUT","suspense_ien")
;
M RESPONSE=^TMP($J,"RMPV","OUT")
;M ^TMP("SLT",$J,"response")=RESPONSE
Q
ETRAP ;error trap tag
D ^%ZTER,UNWIND^%ZTER
Q
ERROR(MSG) ; Set error return
S ^TMP($J,"RMPV","OUT","http_response","message")=MSG
S ^TMP($J,"RMPV","OUT","http_response","http_status_code")=422
Q
ISERROR() ; If error, simulate up-arrow and return 1
Q:^TMP($J,"RMPV","OUT","http_response","http_status_code")=200 0
S (X,Y)="^",DUOUT=""
Q 1
LOADVARS(REQUEST) ; Load input variables into globals
M ^TMP($J,"RMPV","IN")=REQUEST
; Optional input
D SETDFLT("type_of_transaction","S")
D SETDFLT("quantity",1)
D SETDFLT("inventory_location","")
D SETDFLT("hcpcs","")
D SETDFLT("issue_date","T")
D SETDFLT("serial_number","")
D SETDFLT("lot_number","")
D SETDFLT("remarks","")
Q
SETDFLT(PROP,DFLT) ; Set defaults
S ^TMP($J,"RMPV","IN",PROP)=$G(^TMP($J,"RMPV","IN",PROP),DFLT)
Q
FINDSUSP(DFN,CONSULT) ; Find suspense record
N SUSPIDX,SUSPIEN S (SUSPIDX,SUSPIEN)=""
F S SUSPIDX=$O(^RMPR(668,"C",DFN,SUSPIDX),-1) Q:'SUSPIDX D Q:SUSPIEN
.N STATUS S STATUS=$P(^RMPR(668,SUSPIDX,0),U,10)
.N CNSLT S CNSLT=$P(^RMPR(668,SUSPIDX,0),U,15)
.I "OP"[STATUS,CNSLT=CONSULT S SUSPIEN=SUSPIDX
Q SUSPIEN
INIT ; initialization
K ^TMP($J,"RMPV","CALLED")
S ^TMP($J,"RMPV","CB","GETPAT+2^RMPRUTIL")="GETPAT^RMPVS633"
S ^TMP($J,"RMPV","CB","ASK1+12^RMPRPAT")="SCREEN^RMPVS633"
S ^TMP($J,"RMPV","CB","AMP^RMPRDIS")="PDCA^RMPVS633"
S ^TMP($J,"RMPV","CB","EDIT+1^RMPRDIS")="PDCE^RMPVS633"
S ^TMP($J,"RMPV","CB","SEL+2^RMPRDIS")="PDCS^RMPVS633"
S ^TMP($J,"RMPV","CB","TRAN+7^RMPRPIYI")="TRAN^RMPVS633"
S ^TMP($J,"RMPV","CB","PCAT+2^RMPRPIYI")="PCAT^RMPVS633"
S ^TMP($J,"RMPV","CB","SPE^RMPRPIYI")="SPE^RMPVS633"
S ^TMP($J,"RMPV","CB","BARC1^RMPRPIYS")="BARC1^RMPVS633"
S ^TMP($J,"RMPV","CB","QTY+1^RMPRPIYJ")="QTY^RMPVS633"
S ^TMP($J,"RMPV","CB","SERV+3^RMPRPIYJ")="DATESERV^RMPVS633"
S ^TMP($J,"RMPV","CB","LI+1^RMPRPIYJ")="SER^RMPVS633"
S ^TMP($J,"RMPV","CB","LOT+3^RMPRPIYJ")="LOT^RMPVS633"
S ^TMP($J,"RMPV","CB","REMA+3^RMPRPIYJ")="REMA^RMPVS633"
S ^TMP($J,"RMPV","CB","LIST+9^RMPRPIYJ")="PED^RMPVS633"
;
S ^TMP($J,"RMPV","CB","DIV4+7^RMPRSIT")="SITE^RMPVS633"
S ^TMP($J,"RMPV","CB","GETPAT+12^RMPRUTIL")="DECEASED^RMPVS633"
S ^TMP($J,"RMPV","CB","EN+3^RMPRDIS")="NOOP^RMPVS633"
Q
;
SCREEN ; Select a screen "ASK1+12^RMPRPAT"
S (X,Y)=""
Q
GETPAT ; Select patient "GETPAT+2^RMPRUTIL"
S DIC="^RMPR(665,",DIC(0)="MLQ",X=^TMP($J,"RMPV","IN","patient_ssn")
D ^DIC
Q
PDCA ; Add prosthetic disability code "AMP^RMPRDIS"
; Called more than once. Only create an entry on the first call.
I $D(^TMP($J,"RMPV","CALLED","PDCE")) S Y=-1 Q
N FDA,IENS,IENROOT,MSG
S IENS="+1,"_DA(1)_","
S FDA(665.01,IENS,.01)="AO/DIS"
D UPDATE^DIE("E","FDA","IENROOT","MSG")
S Y=IENROOT(1)_U_"AO/DIS"_U_1
S ^TMP($J,"RMPV","CALLED","PDCE")=""
Q
PDCE ; Edit prosthetic disability code "EDIT+1^RMPRDIS"
N FDA,IENS,MSG
S IENS=DA_","_DA(1)_","
S FDA(665.01,IENS,2)=2
S FDA(665.01,IENS,3)=4
S FDA(665.01,IENS,4)=8
D FILE^DIE(,"FDA","MSG")
Q
PDCS ; Select prosthetic disability code "SEL+2^RMPRDIS"
S Y=-1
Q
TRAN ; Transaction type "TRAN+7^RMPRPIYI"
I $D(^TMP($J,"RMPV","CALLED","TTYPE")) D Q
.S (X,Y)=""
.K ^TMP($J,"RMPRPCE") ; Force RMPRPIYI to not call LINK^RMPRS and exit
S (X,Y)=^TMP($J,"RMPV","IN","type_of_transaction")
S ^TMP($J,"RMPV","CALLED","TTYPE")=""
Q
PCAT ; Patient category "PCAT+2^RMPRIYI"
S X=4,Y=4,Y(0)="NSC/OP"
Q
SPE ; Special category "SPE^RMPRPIYI"
S X=4,Y=4,Y(0)="ELIGIBILITY REFORM"
Q
BARC1 ; Barcode "BARC1^RMPRPIYS"
Q:$$ISERROR
S (X,Y)=^TMP($J,"RMPV","IN","barcode_key")
Q
QTY ; Quantity "QTY+1^RMPRPIYJ"
Q:$$ISERROR
S (X,Y)=^TMP($J,"RMPV","IN","quantity")
Q
DATESERV ; Date of service "SERV+3^RMPRPIYJ"
S %DT="",X=^TMP($J,"RMPV","IN","issue_date")
D ^%DT
Q
SER ; Serial number "LI+1^RMPRPIYJ"
S (X,Y)=^TMP($J,"RMPV","IN","serial_number")
Q
LOT ; Lot number "LOT+3^RMPRPIYJ"
S (X,Y)=^TMP($J,"RMPV","IN","lot_number")
Q
REMA ; Remarks "REMA+3^RMPRPIYJ"
S (X,Y)=^TMP($J,"RMPV","IN","remarks")
Q
PED ; POST/EDIT/DELETE stock issue "LIST+9^RMPRPIYJ"
Q:$$ISERROR
S (X,Y)="P"
Q
XSITE ; Site selection (669.9) "DIV+4^RMPRSIT"
S X=^TMP($J,"RMPV","IN","inventory_location")
S DIC="^RMPR(660.9,",DIC(0)="EQM" D ^DIC
Q
SITE ; Site selection (669.9) "DIV+4^RMPRSIT"
N X,DIC,INSTIEN
S X=^TMP($J,"RMPV","IN","inventory_location")
S DIC="^RMPR(661.5,",DIC(0)="OZ" D ^DIC
I Y'=-1,$D(Y)=11 D
. S INSTIEN=$P(Y(0),U,2)
. K Y
. I $D(^RMPR(669.9,"C",INSTIEN)) S Y=$O(^RMPR(669.9,"C",INSTIEN,""))
. E S Y=-1 D ERROR("Institution not found in PROSTHETICS SITE PARAMETERS file.") Q
E D ERROR(^TMP($J,"RMPV","IN","inventory_location")_" is not a valid Inventory Location.") Q
Q
DECEASED ; Patient deceased "GETPAT+12^RMPRUTIL"
S X="Y",Y=1
Q
NOOP ; Never called in Legacy "EN+3^RMPRDIS"
S X="N",Y=0 ; default to NO
Q
;
;
DISCHK(REQ) ;disability code checker
;
N consultIEN,patientSSN,disabilityCodes
S consultIEN=REQ("consult_ien")
S patientSSN=REQ("patient_ssn")
S patientIEN=$$FIND1^DIC(2,"","X",patientSSN,"SSN")
D GETS^DIQ(665,patientIEN_",","10*","","disabilityCodes")
Q $D(disabilityCodes)
;
%WRITE(EREF,ARG) ; WRITE handler
;I ARG="Posted to 2319..." K RMPR60("IEN")
I ARG="Posted to 2319...",$G(RMPR60("IEN"))<1 D ERROR("No appliance repair found...") Q
I ARG="Posted to 2319..." S ^TMP($J,"RMPV","OUT","appliance_repair_ien")=$G(RMPR60("IEN")) Q
I ARG["The Item scanned is not available" D Q
.S ^TMP("JDA","WRITE")=1
.D ERROR(^TMP($J,"RMPV","IN","barcode_key")_" is not found in VISTA or is not in stock. Check Inventory Levels.") Q
I ARG["Issue quantity exceeds on-hand" D Q
.D ERROR(^TMP($J,"RMPV","IN","barcode_key")_" has insufficient quantity to complete this transaction.") Q
;
I ARG["A problem has occurred with the scan, please try again." D Q
.D ERROR("Invalid Inventory Item/Location") Q
Q
;
; Generator tags
%EREF() ; original entry point
Q "EN7^RMPROP"
%FOLLOW(TAG,ROUTINE) ; Should generator follow calls to tag^routine
I TAG="CPT",ROUTINE="RMPRPIYS" Q 0
I TAG="LINK",ROUTINE="RMPRS" Q 0
I TAG="QUE",ROUTINE="RMPRPAT" Q 0
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPVS633 9500 printed May 25, 2026@12:51:05 Page 2
RMPVS633 ; OIT/JDA - SCAMP runtime support; Nov 17, 2024@23:35:37
+1 ;;1.0;PROSTHETICS VISION 4 SIGHT II;**2**;Jan 31, 2025;Build 38
+2 ;
+3 ; Reference to file #668 supported by ICR #6540
+4 ; Reference to file #665 supported by ICR #6537
+5 ; Reference to file #2 (^DPT) supported by ICR #7019
+6 ;
+7 QUIT
TEST ;test tag
+1 ;TSTART
+2 NEW REQ,RESP
+3 SET REQ("consult_ien")=1396535
+4 SET REQ("patient_ssn")=557635084
+5 SET REQ("barcode_key")="V2100-3240916104909"
+6 DO RUN(.REQ,.RESP)
+7 USE $PRINCIPAL
+8 ;zw RESP
+9 QUIT
TEST2 ;test tag
+1 ;TSTART
+2 NEW REQ,RESP
+3 SET REQ("consult_ien")=1397538
+4 SET REQ("patient_ssn")=614659908
+5 SET REQ("barcode_key")="A9300-324121253536"
+6 DO RUN(.REQ,.RESP)
+7 USE $PRINCIPAL
+8 ;zw RESP
+9 QUIT
TEST3 ;test tag
+1 ;TSTART
+2 NEW REQ,RESP
+3 SET REQ("consult_ien")=282223
+4 SET REQ("patient_ssn")=571366114
+5 SET REQ("barcode_key")="A4500-3190723101447"
+6 SET REQ("inventory_location")="4SIGHTTEST"
+7 SET REQ("hcpcs")="A4500"
+8 SET REQ("type_of_transaction")="S"
+9 SET REQ("issue_date")="Dec 17, 2024"
+10 SET REQ("quantity")=1
+11 SET REQ("remarks")="none"
+12 DO RUN(.REQ,.RESP)
+13 USE $PRINCIPAL
+14 ;zw RESP
+15 QUIT
+16 ;
TEST4 ; test tag for multiples
+1 ;
+2 NEW ARY,I,REQUEST
+3 ;
+4 SET ARY(1,"consult_ien")=1036763
+5 SET ARY(1,"patient_ssn")="032794208"
+6 SET ARY(1,"barcode_key")="A4565-3250219164758"
+7 SET ARY(1,"inventory_location")="4SIGHTTEST"
+8 SET ARY(1,"hcpcs")="A4565"
+9 SET ARY(1,"type_of_transaction")="S"
+10 SET ARY(1,"issue_date")="Feb 19, 2025"
+11 SET ARY(1,"quantity")=1
+12 SET ARY(1,"remarks")="none"
+13 ;
+14 SET ARY(2,"consult_ien")=1036764
+15 SET ARY(2,"patient_ssn")="112044625"
+16 SET ARY(2,"barcode_key")="A4565-3250219164758"
+17 SET ARY(2,"inventory_location")="4SIGHTTEST"
+18 SET ARY(2,"hcpcs")="A4565"
+19 SET ARY(2,"type_of_transaction")="S"
+20 SET ARY(2,"issue_date")="Feb 19, 2025"
+21 SET ARY(2,"quantity")=1
+22 SET ARY(2,"remarks")="none"
+23 ;
+24 SET ARY(3,"consult_ien")=1036778
+25 SET ARY(3,"patient_ssn")="012397949"
+26 SET ARY(3,"barcode_key")="A4565-3250219164758"
+27 SET ARY(3,"inventory_location")="4SIGHTTEST"
+28 SET ARY(3,"hcpcs")="A4565"
+29 SET ARY(3,"type_of_transaction")="S"
+30 SET ARY(3,"issue_date")="Feb 19, 2025"
+31 SET ARY(3,"quantity")=1
+32 SET ARY(3,"remarks")="none"
+33 ;
+34 FOR I=1:1:3
Begin DoDot:1
+35 NEW RESP,REQUEST
+36 MERGE REQUEST=ARY(I)
+37 DO RUN(.REQUEST,.RESP)
+38 ;ZW RESP
+39 QUIT
End DoDot:1
+40 QUIT
+41 ;
RUN(REQUEST,RESPONSE) ; set up input/output vars and run
+1 NEW $ESTACK,$ETRAP
SET $ETRAP="D ETRAP^RMPVS633"
+2 KILL ^TMP($JOB,"RMPV")
+3 NEW DFN
SET DFN=$ORDER(^DPT("SSN",REQUEST("patient_ssn"),""))
+4 IF 'DFN
Begin DoDot:1
+5 DO ERROR("Could not locate a patient with a matching SSN.")
+6 MERGE RESPONSE=^TMP($JOB,"RMPV","OUT")
End DoDot:1
QUIT
+7 NEW SUSP
SET SUSP=$$FINDSUSP(DFN,REQUEST("consult_ien"))
+8 IF 'SUSP
Begin DoDot:1
+9 DO ERROR("Suspense record in desired status not found.")
+10 MERGE RESPONSE=^TMP($JOB,"RMPV","OUT")
End DoDot:1
QUIT
+11 IF '$$DISCHK(.REQUEST)
Begin DoDot:1
+12 DO ERROR("Failed to update; patient missing disability code.")
+13 SET ^TMP($JOB,"RMPV","OUT","consult_ien")=REQUEST("consult_ien")
+14 MERGE RESPONSE=^TMP($JOB,"RMPV","OUT")
+15 QUIT
End DoDot:1
QUIT
+16 SET ^TMP($JOB,"RMPV","OUT","http_response","http_status_code")=200
+17 SET ^TMP($JOB,"RMPV","OUT","http_response","message")=""
+18 SET ^TMP($JOB,"RMPV","OUT","suspense_ien")=SUSP
+19 SET ^TMP($JOB,"RMPV","OUT","consult_ien")=REQUEST("consult_ien")
+20 DO LOADVARS(.REQUEST)
+21 ;
+22 Begin DoDot:1
+23 DO RUN^RMPVDRV("EN7^RMPV0RMPROP",$TEXT(+0))
End DoDot:1
+24 IF $$ISERROR
KILL ^TMP($JOB,"RMPV","OUT","suspense_ien")
+25 ;
+26 MERGE RESPONSE=^TMP($JOB,"RMPV","OUT")
+27 ;M ^TMP("SLT",$J,"response")=RESPONSE
+28 QUIT
ETRAP ;error trap tag
+1 DO ^%ZTER
DO UNWIND^%ZTER
+2 QUIT
ERROR(MSG) ; Set error return
+1 SET ^TMP($JOB,"RMPV","OUT","http_response","message")=MSG
+2 SET ^TMP($JOB,"RMPV","OUT","http_response","http_status_code")=422
+3 QUIT
ISERROR() ; If error, simulate up-arrow and return 1
+1 if ^TMP($JOB,"RMPV","OUT","http_response","http_status_code")=200
QUIT 0
+2 SET (X,Y)="^"
SET DUOUT=""
+3 QUIT 1
LOADVARS(REQUEST) ; Load input variables into globals
+1 MERGE ^TMP($JOB,"RMPV","IN")=REQUEST
+2 ; Optional input
+3 DO SETDFLT("type_of_transaction","S")
+4 DO SETDFLT("quantity",1)
+5 DO SETDFLT("inventory_location","")
+6 DO SETDFLT("hcpcs","")
+7 DO SETDFLT("issue_date","T")
+8 DO SETDFLT("serial_number","")
+9 DO SETDFLT("lot_number","")
+10 DO SETDFLT("remarks","")
+11 QUIT
SETDFLT(PROP,DFLT) ; Set defaults
+1 SET ^TMP($JOB,"RMPV","IN",PROP)=$GET(^TMP($JOB,"RMPV","IN",PROP),DFLT)
+2 QUIT
FINDSUSP(DFN,CONSULT) ; Find suspense record
+1 NEW SUSPIDX,SUSPIEN
SET (SUSPIDX,SUSPIEN)=""
+2 FOR
SET SUSPIDX=$ORDER(^RMPR(668,"C",DFN,SUSPIDX),-1)
if 'SUSPIDX
QUIT
Begin DoDot:1
+3 NEW STATUS
SET STATUS=$PIECE(^RMPR(668,SUSPIDX,0),U,10)
+4 NEW CNSLT
SET CNSLT=$PIECE(^RMPR(668,SUSPIDX,0),U,15)
+5 IF "OP"[STATUS
IF CNSLT=CONSULT
SET SUSPIEN=SUSPIDX
End DoDot:1
if SUSPIEN
QUIT
+6 QUIT SUSPIEN
INIT ; initialization
+1 KILL ^TMP($JOB,"RMPV","CALLED")
+2 SET ^TMP($JOB,"RMPV","CB","GETPAT+2^RMPRUTIL")="GETPAT^RMPVS633"
+3 SET ^TMP($JOB,"RMPV","CB","ASK1+12^RMPRPAT")="SCREEN^RMPVS633"
+4 SET ^TMP($JOB,"RMPV","CB","AMP^RMPRDIS")="PDCA^RMPVS633"
+5 SET ^TMP($JOB,"RMPV","CB","EDIT+1^RMPRDIS")="PDCE^RMPVS633"
+6 SET ^TMP($JOB,"RMPV","CB","SEL+2^RMPRDIS")="PDCS^RMPVS633"
+7 SET ^TMP($JOB,"RMPV","CB","TRAN+7^RMPRPIYI")="TRAN^RMPVS633"
+8 SET ^TMP($JOB,"RMPV","CB","PCAT+2^RMPRPIYI")="PCAT^RMPVS633"
+9 SET ^TMP($JOB,"RMPV","CB","SPE^RMPRPIYI")="SPE^RMPVS633"
+10 SET ^TMP($JOB,"RMPV","CB","BARC1^RMPRPIYS")="BARC1^RMPVS633"
+11 SET ^TMP($JOB,"RMPV","CB","QTY+1^RMPRPIYJ")="QTY^RMPVS633"
+12 SET ^TMP($JOB,"RMPV","CB","SERV+3^RMPRPIYJ")="DATESERV^RMPVS633"
+13 SET ^TMP($JOB,"RMPV","CB","LI+1^RMPRPIYJ")="SER^RMPVS633"
+14 SET ^TMP($JOB,"RMPV","CB","LOT+3^RMPRPIYJ")="LOT^RMPVS633"
+15 SET ^TMP($JOB,"RMPV","CB","REMA+3^RMPRPIYJ")="REMA^RMPVS633"
+16 SET ^TMP($JOB,"RMPV","CB","LIST+9^RMPRPIYJ")="PED^RMPVS633"
+17 ;
+18 SET ^TMP($JOB,"RMPV","CB","DIV4+7^RMPRSIT")="SITE^RMPVS633"
+19 SET ^TMP($JOB,"RMPV","CB","GETPAT+12^RMPRUTIL")="DECEASED^RMPVS633"
+20 SET ^TMP($JOB,"RMPV","CB","EN+3^RMPRDIS")="NOOP^RMPVS633"
+21 QUIT
+22 ;
SCREEN ; Select a screen "ASK1+12^RMPRPAT"
+1 SET (X,Y)=""
+2 QUIT
GETPAT ; Select patient "GETPAT+2^RMPRUTIL"
+1 SET DIC="^RMPR(665,"
SET DIC(0)="MLQ"
SET X=^TMP($JOB,"RMPV","IN","patient_ssn")
+2 DO ^DIC
+3 QUIT
PDCA ; Add prosthetic disability code "AMP^RMPRDIS"
+1 ; Called more than once. Only create an entry on the first call.
+2 IF $DATA(^TMP($JOB,"RMPV","CALLED","PDCE"))
SET Y=-1
QUIT
+3 NEW FDA,IENS,IENROOT,MSG
+4 SET IENS="+1,"_DA(1)_","
+5 SET FDA(665.01,IENS,.01)="AO/DIS"
+6 DO UPDATE^DIE("E","FDA","IENROOT","MSG")
+7 SET Y=IENROOT(1)_U_"AO/DIS"_U_1
+8 SET ^TMP($JOB,"RMPV","CALLED","PDCE")=""
+9 QUIT
PDCE ; Edit prosthetic disability code "EDIT+1^RMPRDIS"
+1 NEW FDA,IENS,MSG
+2 SET IENS=DA_","_DA(1)_","
+3 SET FDA(665.01,IENS,2)=2
+4 SET FDA(665.01,IENS,3)=4
+5 SET FDA(665.01,IENS,4)=8
+6 DO FILE^DIE(,"FDA","MSG")
+7 QUIT
PDCS ; Select prosthetic disability code "SEL+2^RMPRDIS"
+1 SET Y=-1
+2 QUIT
TRAN ; Transaction type "TRAN+7^RMPRPIYI"
+1 IF $DATA(^TMP($JOB,"RMPV","CALLED","TTYPE"))
Begin DoDot:1
+2 SET (X,Y)=""
+3 ; Force RMPRPIYI to not call LINK^RMPRS and exit
KILL ^TMP($JOB,"RMPRPCE")
End DoDot:1
QUIT
+4 SET (X,Y)=^TMP($JOB,"RMPV","IN","type_of_transaction")
+5 SET ^TMP($JOB,"RMPV","CALLED","TTYPE")=""
+6 QUIT
PCAT ; Patient category "PCAT+2^RMPRIYI"
+1 SET X=4
SET Y=4
SET Y(0)="NSC/OP"
+2 QUIT
SPE ; Special category "SPE^RMPRPIYI"
+1 SET X=4
SET Y=4
SET Y(0)="ELIGIBILITY REFORM"
+2 QUIT
BARC1 ; Barcode "BARC1^RMPRPIYS"
+1 if $$ISERROR
QUIT
+2 SET (X,Y)=^TMP($JOB,"RMPV","IN","barcode_key")
+3 QUIT
QTY ; Quantity "QTY+1^RMPRPIYJ"
+1 if $$ISERROR
QUIT
+2 SET (X,Y)=^TMP($JOB,"RMPV","IN","quantity")
+3 QUIT
DATESERV ; Date of service "SERV+3^RMPRPIYJ"
+1 SET %DT=""
SET X=^TMP($JOB,"RMPV","IN","issue_date")
+2 DO ^%DT
+3 QUIT
SER ; Serial number "LI+1^RMPRPIYJ"
+1 SET (X,Y)=^TMP($JOB,"RMPV","IN","serial_number")
+2 QUIT
LOT ; Lot number "LOT+3^RMPRPIYJ"
+1 SET (X,Y)=^TMP($JOB,"RMPV","IN","lot_number")
+2 QUIT
REMA ; Remarks "REMA+3^RMPRPIYJ"
+1 SET (X,Y)=^TMP($JOB,"RMPV","IN","remarks")
+2 QUIT
PED ; POST/EDIT/DELETE stock issue "LIST+9^RMPRPIYJ"
+1 if $$ISERROR
QUIT
+2 SET (X,Y)="P"
+3 QUIT
XSITE ; Site selection (669.9) "DIV+4^RMPRSIT"
+1 SET X=^TMP($JOB,"RMPV","IN","inventory_location")
+2 SET DIC="^RMPR(660.9,"
SET DIC(0)="EQM"
DO ^DIC
+3 QUIT
SITE ; Site selection (669.9) "DIV+4^RMPRSIT"
+1 NEW X,DIC,INSTIEN
+2 SET X=^TMP($JOB,"RMPV","IN","inventory_location")
+3 SET DIC="^RMPR(661.5,"
SET DIC(0)="OZ"
DO ^DIC
+4 IF Y'=-1
IF $DATA(Y)=11
Begin DoDot:1
+5 SET INSTIEN=$PIECE(Y(0),U,2)
+6 KILL Y
+7 IF $DATA(^RMPR(669.9,"C",INSTIEN))
SET Y=$ORDER(^RMPR(669.9,"C",INSTIEN,""))
+8 IF '$TEST
SET Y=-1
DO ERROR("Institution not found in PROSTHETICS SITE PARAMETERS file.")
QUIT
End DoDot:1
+9 IF '$TEST
DO ERROR(^TMP($JOB,"RMPV","IN","inventory_location")_" is not a valid Inventory Location.")
QUIT
+10 QUIT
DECEASED ; Patient deceased "GETPAT+12^RMPRUTIL"
+1 SET X="Y"
SET Y=1
+2 QUIT
NOOP ; Never called in Legacy "EN+3^RMPRDIS"
+1 ; default to NO
SET X="N"
SET Y=0
+2 QUIT
+3 ;
+4 ;
DISCHK(REQ) ;disability code checker
+1 ;
+2 NEW consultIEN,patientSSN,disabilityCodes
+3 SET consultIEN=REQ("consult_ien")
+4 SET patientSSN=REQ("patient_ssn")
+5 SET patientIEN=$$FIND1^DIC(2,"","X",patientSSN,"SSN")
+6 DO GETS^DIQ(665,patientIEN_",","10*","","disabilityCodes")
+7 QUIT $DATA(disabilityCodes)
+8 ;
%WRITE(EREF,ARG) ; WRITE handler
+1 ;I ARG="Posted to 2319..." K RMPR60("IEN")
+2 IF ARG="Posted to 2319..."
IF $GET(RMPR60("IEN"))<1
DO ERROR("No appliance repair found...")
QUIT
+3 IF ARG="Posted to 2319..."
SET ^TMP($JOB,"RMPV","OUT","appliance_repair_ien")=$GET(RMPR60("IEN"))
QUIT
+4 IF ARG["The Item scanned is not available"
Begin DoDot:1
+5 SET ^TMP("JDA","WRITE")=1
+6 DO ERROR(^TMP($JOB,"RMPV","IN","barcode_key")_" is not found in VISTA or is not in stock. Check Inventory Levels.")
QUIT
End DoDot:1
QUIT
+7 IF ARG["Issue quantity exceeds on-hand"
Begin DoDot:1
+8 DO ERROR(^TMP($JOB,"RMPV","IN","barcode_key")_" has insufficient quantity to complete this transaction.")
QUIT
End DoDot:1
QUIT
+9 ;
+10 IF ARG["A problem has occurred with the scan, please try again."
Begin DoDot:1
+11 DO ERROR("Invalid Inventory Item/Location")
QUIT
End DoDot:1
QUIT
+12 QUIT
+13 ;
+14 ; Generator tags
%EREF() ; original entry point
+1 QUIT "EN7^RMPROP"
%FOLLOW(TAG,ROUTINE) ; Should generator follow calls to tag^routine
+1 IF TAG="CPT"
IF ROUTINE="RMPRPIYS"
QUIT 0
+2 IF TAG="LINK"
IF ROUTINE="RMPRS"
QUIT 0
+3 IF TAG="QUE"
IF ROUTINE="RMPRPAT"
QUIT 0
+4 QUIT 1
