PSO508PO ;ALB/BWF - patch 508 post-install ; 1/09/2018 10:43am
;;7.0;OUTPATIENT PHARMACY;**508**;DEC 1997;Build 295
;
EN ;
N DIK,DA
D ERXTYP,ERXPOP,WSUPD
S DIK="^PS(52.49,",DIK(1)=".02^RTMID" D ENALL^DIK K DIK
S DIK="^PS(52.49,",DIK(1)="25^CHVID" D ENALL^DIK K DIK
S DIK="^PS(52.49,",DIK(1)=".14^RTHID" D ENALL^DIK K DIK
S DIK="^PS(52.49,",DIK(1)=".04^PAT2" D ENALL^DIK K DIK
S DIK="^PS(52.49,",DIK(1)=".08^MTYPE" D ENALL^DIK K DIK
;
S I=0 F S I=$O(^PS(52.49,I)) Q:'I D
.S DIK="^PS(52.49,"_I_",100,",DIK(1)=".02^C",DA(1)=I
.D ENALL^DIK K DIK,DA
Q
ERXTYP ;
N I
S I=0
F S I=$O(^PS(52.49,I)) Q:'I D
.I $$GET1^DIQ(52.49,I,.08,"I")]"" Q
.S FDA(52.49,I_",",.08)="N" D FILE^DIE(,"FDA") K FDA
Q
ERXPOP ;
N I,DONE,NIEN,ELINE,ECODE,EDESC,ELONG,EIEN,TYPE,SUB
F TYPE="ERXSTAT","CLQUAL","ERR" D
.I TYPE="ERXSTAT" S SUB="ERX"
.I TYPE="CLQUAL" S SUB="CLQ"
.I TYPE="ERR" S SUB="ERR"
.S DONE=0
.F I=1:1 D Q:DONE
..K NIEN
..I TYPE="ERR" S ELINE=$T(@TYPE+I^PSOERXZ1),ELINE=$P(ELINE,";;",2)
..I TYPE'="ERR" S ELINE=$T(@TYPE+I),ELINE=$P(ELINE,";;",2)
..I ELINE=" Q"!(ELINE="") S DONE=1 Q
..S ECODE=$P(ELINE,U),EDESC=$P(ELINE,U,2),ELONG=$P(ELINE,U,3)
..I $D(^PS(52.45,"C",SUB,ECODE)) D Q
...S EIEN=$O(^PS(52.45,"C",SUB,ECODE,0)) Q:'EIEN
...S FDA(52.45,EIEN_",",.01)=ECODE
...S FDA(52.45,EIEN_",",.02)=EDESC
...S FDA(52.45,EIEN_",",.03)=SUB
...D FILE^DIE(,"FDA") K FDA
..S FDA(52.45,"+1,",.01)=ECODE
..S FDA(52.45,"+1,",.02)=EDESC
..S FDA(52.45,"+1,",.03)=SUB
..D UPDATE^DIE(,"FDA","NIEN") K FDA
Q
WSUPD ;
N WSIEN,WSIENS,DIE,DR,DA
S WSIEN=$$FIND1^DIC(18.12,,,"PSO WEB SERVER","B") Q:'WSIEN
; disable web service
S DIE="^XOB(18.12,",DR=".06///0",DA=WSIEN D ^DIE K DIE,DR,DA
S WSIENS=WSIEN_","
S FDA(18.12,WSIENS,.04)=""
S FDA(18.12,WSIENS,200)=""
S FDA(18.12,WSIENS,300)=""
; clear server, password, and username fields
D FILE^DIE(,"FDA") K FDA
Q
ERXSTAT ;
;;IEA^INBOUND ERROR ACKNOWLEDGED
;;RRN^REFILL REQUEST - NEW
;;RRX^REFILL REQUEST EXPIRED
;;RRR^REFILL REQUEST RESPONSE RECEIVED
;;RRE^REFILL REQUEST ERROR
;;RRP^REFILL REQUEST PROCESSED
;;RRF^REFILL REQUEST FAILED
;;RRC^REFILL REQUEST COMPLETE
;;RXA^REFILL RESPONSE ACKNOWLEDGED
;;RXD^REFILL RESPONSE DENIED/DNTF
;;RXN^REFILL RESPONSE - NEW
;;RXF^REFILL RESPONSE FAILED
;;RXP^REFILL RESPONSE PROCESSED
;;RXC^REFILL RESPONSE COMPLETE
;;RXW^REFILL RESPONSE WAITING
;;CAN^ORIGINAL ERX CANCELED IN THE HOLDING QUEUE
;;CNP^CANCEL RESPONSE PROCESSED
;;CAO^CANCEL PROCESS COMPLETE
;;CAH^CANCEL COMPLETED IN HOLDING QUEUE
;;CAA^CANCEL REQUEST ACKNOWLEDGED
;;CAR^CANCEL REQUEST RECEIVED
;;CNE^CANCEL RESPONSE/INBOUND ERROR
;;CAF^CANCEL PROCESS FAILED
;;CAP^CANCEL PAPER RX OR FAXED RX
;;CAX^CANCEL RESPONSE FROM VISTA UNSUCCESSFUL
;;IRA^INBOUND REFREQ ERROR ACKNOWLEDGED
Q
; code list qualifiers
CLQUAL ;
;;AA^Patient unknown to the Prescriber
;;AB^Patient never under Prescriber care
;;AC^Patient no longer under Prescriber care
;;AD^Patient has requested refill too soon
;;AE^Medication never prescribed for the patient
;;AF^Patient should contact Prescriber first
;;AG^Refill not appropriate
;;AH^Patient has picked up prescription
;;AJ^Patient has picked up partial fill of prescription
;;AK^Patient has not picked up prescription, drug returned to stock
;;AL^Change not appropriate
;;AM^Patient needs appointment
;;AN^Prescriber not associated with this practice or location.
;;AO^No attempt will be made to obtain Prior Authorization
;;AP^Request already responded to by other means (e.g. phone or fax)
;;AQ^More Medication History Available
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSO508PO 3685 printed Sep 23, 2025@19:59:10 Page 2
PSO508PO ;ALB/BWF - patch 508 post-install ; 1/09/2018 10:43am
+1 ;;7.0;OUTPATIENT PHARMACY;**508**;DEC 1997;Build 295
+2 ;
EN ;
+1 NEW DIK,DA
+2 DO ERXTYP
DO ERXPOP
DO WSUPD
+3 SET DIK="^PS(52.49,"
SET DIK(1)=".02^RTMID"
DO ENALL^DIK
KILL DIK
+4 SET DIK="^PS(52.49,"
SET DIK(1)="25^CHVID"
DO ENALL^DIK
KILL DIK
+5 SET DIK="^PS(52.49,"
SET DIK(1)=".14^RTHID"
DO ENALL^DIK
KILL DIK
+6 SET DIK="^PS(52.49,"
SET DIK(1)=".04^PAT2"
DO ENALL^DIK
KILL DIK
+7 SET DIK="^PS(52.49,"
SET DIK(1)=".08^MTYPE"
DO ENALL^DIK
KILL DIK
+8 ;
+9 SET I=0
FOR
SET I=$ORDER(^PS(52.49,I))
if 'I
QUIT
Begin DoDot:1
+10 SET DIK="^PS(52.49,"_I_",100,"
SET DIK(1)=".02^C"
SET DA(1)=I
+11 DO ENALL^DIK
KILL DIK,DA
End DoDot:1
+12 QUIT
ERXTYP ;
+1 NEW I
+2 SET I=0
+3 FOR
SET I=$ORDER(^PS(52.49,I))
if 'I
QUIT
Begin DoDot:1
+4 IF $$GET1^DIQ(52.49,I,.08,"I")]""
QUIT
+5 SET FDA(52.49,I_",",.08)="N"
DO FILE^DIE(,"FDA")
KILL FDA
End DoDot:1
+6 QUIT
ERXPOP ;
+1 NEW I,DONE,NIEN,ELINE,ECODE,EDESC,ELONG,EIEN,TYPE,SUB
+2 FOR TYPE="ERXSTAT","CLQUAL","ERR"
Begin DoDot:1
+3 IF TYPE="ERXSTAT"
SET SUB="ERX"
+4 IF TYPE="CLQUAL"
SET SUB="CLQ"
+5 IF TYPE="ERR"
SET SUB="ERR"
+6 SET DONE=0
+7 FOR I=1:1
Begin DoDot:2
+8 KILL NIEN
+9 IF TYPE="ERR"
SET ELINE=$TEXT(@TYPE+I^PSOERXZ1)
SET ELINE=$PIECE(ELINE,";;",2)
+10 IF TYPE'="ERR"
SET ELINE=$TEXT(@TYPE+I)
SET ELINE=$PIECE(ELINE,";;",2)
+11 IF ELINE=" Q"!(ELINE="")
SET DONE=1
QUIT
+12 SET ECODE=$PIECE(ELINE,U)
SET EDESC=$PIECE(ELINE,U,2)
SET ELONG=$PIECE(ELINE,U,3)
+13 IF $DATA(^PS(52.45,"C",SUB,ECODE))
Begin DoDot:3
+14 SET EIEN=$ORDER(^PS(52.45,"C",SUB,ECODE,0))
if 'EIEN
QUIT
+15 SET FDA(52.45,EIEN_",",.01)=ECODE
+16 SET FDA(52.45,EIEN_",",.02)=EDESC
+17 SET FDA(52.45,EIEN_",",.03)=SUB
+18 DO FILE^DIE(,"FDA")
KILL FDA
End DoDot:3
QUIT
+19 SET FDA(52.45,"+1,",.01)=ECODE
+20 SET FDA(52.45,"+1,",.02)=EDESC
+21 SET FDA(52.45,"+1,",.03)=SUB
+22 DO UPDATE^DIE(,"FDA","NIEN")
KILL FDA
End DoDot:2
if DONE
QUIT
End DoDot:1
+23 QUIT
WSUPD ;
+1 NEW WSIEN,WSIENS,DIE,DR,DA
+2 SET WSIEN=$$FIND1^DIC(18.12,,,"PSO WEB SERVER","B")
if 'WSIEN
QUIT
+3 ; disable web service
+4 SET DIE="^XOB(18.12,"
SET DR=".06///0"
SET DA=WSIEN
DO ^DIE
KILL DIE,DR,DA
+5 SET WSIENS=WSIEN_","
+6 SET FDA(18.12,WSIENS,.04)=""
+7 SET FDA(18.12,WSIENS,200)=""
+8 SET FDA(18.12,WSIENS,300)=""
+9 ; clear server, password, and username fields
+10 DO FILE^DIE(,"FDA")
KILL FDA
+11 QUIT
ERXSTAT ;
+1 ;;IEA^INBOUND ERROR ACKNOWLEDGED
+2 ;;RRN^REFILL REQUEST - NEW
+3 ;;RRX^REFILL REQUEST EXPIRED
+4 ;;RRR^REFILL REQUEST RESPONSE RECEIVED
+5 ;;RRE^REFILL REQUEST ERROR
+6 ;;RRP^REFILL REQUEST PROCESSED
+7 ;;RRF^REFILL REQUEST FAILED
+8 ;;RRC^REFILL REQUEST COMPLETE
+9 ;;RXA^REFILL RESPONSE ACKNOWLEDGED
+10 ;;RXD^REFILL RESPONSE DENIED/DNTF
+11 ;;RXN^REFILL RESPONSE - NEW
+12 ;;RXF^REFILL RESPONSE FAILED
+13 ;;RXP^REFILL RESPONSE PROCESSED
+14 ;;RXC^REFILL RESPONSE COMPLETE
+15 ;;RXW^REFILL RESPONSE WAITING
+16 ;;CAN^ORIGINAL ERX CANCELED IN THE HOLDING QUEUE
+17 ;;CNP^CANCEL RESPONSE PROCESSED
+18 ;;CAO^CANCEL PROCESS COMPLETE
+19 ;;CAH^CANCEL COMPLETED IN HOLDING QUEUE
+20 ;;CAA^CANCEL REQUEST ACKNOWLEDGED
+21 ;;CAR^CANCEL REQUEST RECEIVED
+22 ;;CNE^CANCEL RESPONSE/INBOUND ERROR
+23 ;;CAF^CANCEL PROCESS FAILED
+24 ;;CAP^CANCEL PAPER RX OR FAXED RX
+25 ;;CAX^CANCEL RESPONSE FROM VISTA UNSUCCESSFUL
+26 ;;IRA^INBOUND REFREQ ERROR ACKNOWLEDGED
+27 QUIT
+28 ; code list qualifiers
CLQUAL ;
+1 ;;AA^Patient unknown to the Prescriber
+2 ;;AB^Patient never under Prescriber care
+3 ;;AC^Patient no longer under Prescriber care
+4 ;;AD^Patient has requested refill too soon
+5 ;;AE^Medication never prescribed for the patient
+6 ;;AF^Patient should contact Prescriber first
+7 ;;AG^Refill not appropriate
+8 ;;AH^Patient has picked up prescription
+9 ;;AJ^Patient has picked up partial fill of prescription
+10 ;;AK^Patient has not picked up prescription, drug returned to stock
+11 ;;AL^Change not appropriate
+12 ;;AM^Patient needs appointment
+13 ;;AN^Prescriber not associated with this practice or location.
+14 ;;AO^No attempt will be made to obtain Prior Authorization
+15 ;;AP^Request already responded to by other means (e.g. phone or fax)
+16 ;;AQ^More Medication History Available
+17 QUIT
