Routine: PSO508PO

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

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

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

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

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

 ; 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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSO508PO   3685     printed  Feb 18, 2025@23:49:20                                                                                                                                                                                                    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

PSO508PO.m