RMPR9PCD ;HOIFO/HNC - PURCHASE ORDER CHECK PA AUTHORIZATION ;JAN 2003
;;3.0;PROSTHETICS;**90**;Feb 09, 1996
;
Q
B1(DUZ,SITE,RMPR668) G B2
EN1(RESULTS,DUZ,SITE,RMPR668) ;broker entry point
B2 ;
I '$D(^PRC(440.5,"H",DUZ)),'$D(^PRC(440.5,"C",DUZ)) S RESULTS(0)="1^You are not an authorized Purchase Card User, CONTACT FISCAL!"
S RMPRDFN=$P(^RMPR(668,RMPR668,0),U,2)
I '$D(^RMPR(665,RMPRDFN,0)) S RESULTS(0)="1^Patient not defined in PROSTHETICS PATIENT FILE please use the option: AP Add/Edit Patient to Prosthetics and try again." Q
S (RMPRWHO,RMPRSC)="",(LINE,ALL)=0
S RMPRSC=$O(^RMPR(669.9,"PA",DUZ,RMPRSC)) Q:RMPRSC="" D
. I '$D(^RMPR(669.9,RMPRSC,0)) Q
. I '$D(^RMPR(669.9,RMPRSC,5,"B",DUZ)) Q
. S RMPRWHO=$O(^RMPR(669.9,RMPRSC,5,"B",DUZ,""))
I RMPRWHO="" S RESULTS(0)="1^User Not Defined in Site Parmeters File." Q
S PPASSN=$P($G(^VA(200,DUZ,1)),U,9)
I PPASSN="" S RESULTS(0)="1^User Does Not have an SSN in File 200." Q
;
D NOW^%DTC
K DD,DO
;purchasing agent SSN
S $P(RESULTS(0),U,1)=PPASSN
S $P(RESULTS(0),U,2)=RMPRWHO
S $P(RESULTS(0),U,3)=RMPRDFN
Q
EXIT ;common exit point
;END
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR9PCD 1145 printed Sep 23, 2025@20:09:55 Page 2
RMPR9PCD ;HOIFO/HNC - PURCHASE ORDER CHECK PA AUTHORIZATION ;JAN 2003
+1 ;;3.0;PROSTHETICS;**90**;Feb 09, 1996
+2 ;
+3 QUIT
B1(DUZ,SITE,RMPR668) GOTO B2
EN1(RESULTS,DUZ,SITE,RMPR668) ;broker entry point
B2 ;
+1 IF '$DATA(^PRC(440.5,"H",DUZ))
IF '$DATA(^PRC(440.5,"C",DUZ))
SET RESULTS(0)="1^You are not an authorized Purchase Card User, CONTACT FISCAL!"
+2 SET RMPRDFN=$PIECE(^RMPR(668,RMPR668,0),U,2)
+3 IF '$DATA(^RMPR(665,RMPRDFN,0))
SET RESULTS(0)="1^Patient not defined in PROSTHETICS PATIENT FILE please use the option: AP Add/Edit Patient to Prosthetics and try again."
QUIT
+4 SET (RMPRWHO,RMPRSC)=""
SET (LINE,ALL)=0
+5 SET RMPRSC=$ORDER(^RMPR(669.9,"PA",DUZ,RMPRSC))
if RMPRSC=""
QUIT
Begin DoDot:1
+6 IF '$DATA(^RMPR(669.9,RMPRSC,0))
QUIT
+7 IF '$DATA(^RMPR(669.9,RMPRSC,5,"B",DUZ))
QUIT
+8 SET RMPRWHO=$ORDER(^RMPR(669.9,RMPRSC,5,"B",DUZ,""))
End DoDot:1
+9 IF RMPRWHO=""
SET RESULTS(0)="1^User Not Defined in Site Parmeters File."
QUIT
+10 SET PPASSN=$PIECE($GET(^VA(200,DUZ,1)),U,9)
+11 IF PPASSN=""
SET RESULTS(0)="1^User Does Not have an SSN in File 200."
QUIT
+12 ;
+13 DO NOW^%DTC
+14 KILL DD,DO
+15 ;purchasing agent SSN
+16 SET $PIECE(RESULTS(0),U,1)=PPASSN
+17 SET $PIECE(RESULTS(0),U,2)=RMPRWHO
+18 SET $PIECE(RESULTS(0),U,3)=RMPRDFN
+19 QUIT
EXIT ;common exit point
+1 ;END
