Routine: PSO427PS

PSO427PS ;ALB/DMB - Post-install for PSO*7*427 ;10/21/2014

 ;;7.0;OUTPATIENT PHARMACY;**427**;DEC 1997;Build 21

EN ; Entry Point for post-install

 D BMES^XPDUTL("  Starting post-install for PSO*7*427")

 ; Removed Cached protocol menus

 D PROT("PSO REJECT DISPLAY HIDDEN MENU")

 D PROT("PSO REJECTS HIDDEN ACTIONS #1")

 ; Update Insurance Pointer in REJECT INFO subfile

 D INSJOB

 ; Completion message

 D BMES^XPDUTL("  Finished post-install for PSO*7*427")

PROT(MENU) ;

 ; Remove cached hidden menu

 N PSOIEN,XQORM

 S PSOIEN=$O(^ORD(101,"B",MENU,0))

 S XQORM=PSOIEN_";ORD(101,"

 I $D(^XUTL("XQORM",XQORM)) D

 . D MES^XPDUTL("    Removing cached menu for "_$P(^ORD(101,PSOIEN,0),U))

 . K ^XUTL("XQORM",XQORM)

INSJOB ;

 ; Job the process to update the Reject file

 D BMES^XPDUTL("    Queuing background job to update the Reject mult of the Prescription file")

 D MES^XPDUTL("    A Mailman message will be sent when it finishes")

 ; Setup required variables

 S ZTRTN="INS^PSO427PS",ZTIO="",ZTDTH=$H

 S ZTDESC="Background job to update the Prescription file via PSO*7*427"

 ; Task the job

 D ^%ZTLOAD

 ; Check if task was created

 I $D(ZTSK) D MES^XPDUTL("    Task #"_ZTSK_" queued")

 I '$D(ZTSK) D MES^XPDUTL("   Task not queued.  Please create a support ticket.")

INS ;

 ; Entry Point to populate the insurance company pointer in the REJECT INFO subfile

 N CNT,DAT,RX,RN,RSPIEN,INS,IEN57,INSNM

 N DIE,DA,DR,DTOUT,DUOUT,DIROUT,DIRUT

 S CNT=0

 ; Loop through index

 S DAT=0 F  S DAT=$O(^PSRX("REJDAT",DAT)) Q:'DAT  D

 . S RX="" F  S RX=$O(^PSRX("REJDAT",DAT,RX)) Q:'RX  D

 .. S RN="" F  S RN=$O(^PSRX("REJDAT",DAT,RX,RN)) Q:'RN  D

 ... ;If already populated, quit

 ... I $P($G(^PSRX(RX,"REJ",RN,2)),"^",9) Q

 ... ; Get Response pointer

 ... S RSPIEN=$P($G(^PSRX(RX,"REJ",RN,0)),"^",11)

 ... ; If the Response pointer exists, get Log of Transaction record and Insurance Pointer from that file

 ... S (IEN57,INS)=""

 ... I RSPIEN D

 .... S IEN57=$O(^BPSTL("AF",RSPIEN,""))

 .... I IEN57 S INS=$$GET1^DIQ(9002313.57902,"1,"_IEN57_",",902.33,"I")

 .... I INS,'$D(^DIC(36,INS,0)) S INS=""

 ... ; If missing from the Transaction, try to match on the insurance name

 ... ; There can only be one insurance company with the same name

 ... I INS="" D

 .... S INSNM=$P($G(^PSRX(RX,"REJ",RN,2)),"^",4)

 .... I INSNM]"" S INS=$O(^DIC(36,"B",INSNM,""))

 .... I INS,$O(^DIC(36,"B",INSNM,INS)) S INS=""

 ... ; Quit if there is no insurance

 ... I INS="" Q

 ... ; Set insurance company into the field

 ... S DIE="^PSRX("_RX_",""REJ"",",DA(1)=RX,DA=RN,DR=33_"////"_INS

 ... D ^DIE

 ... K DA,DR,DIE

 ... S CNT=CNT+1

 ; Send email with result

 D MAIL(CNT)

MAIL(SUCCNT) ;

 N CNT,MSG,XMY,XMDUZ,DIFROM,XMSUB,XMTEXT

 S XMY(DUZ)=""

 S XMSUB="PSO*7.0*427 Post install is complete",XMDUZ="Patch PSO*7.0*427"

 S XMTEXT="MSG("

 S CNT=1,MSG(CNT)=""

 S CNT=CNT+1,MSG(CNT)="Patch PSO*7.0*427 post install routine has completed."

 S CNT=CNT+1,MSG(CNT)=""

 S CNT=CNT+1,MSG(CNT)="Updated "_SUCCNT_" records in the PRESCRIPTION file."

 S CNT=CNT+1,MSG(CNT)=""

 S CNT=CNT+1,MSG(CNT)="For more information about this post install, review the patch description."

 D ^XMD

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSO427PS   3282     printed  Mar 13, 2025@21:27:47                                                                                                                                                                                                    Page 2

PSO427PS  ;ALB/DMB - Post-install for PSO*7*427 ;10/21/2014

 +1       ;;7.0;OUTPATIENT PHARMACY;**427**;DEC 1997;Build 21

 +2       ;

 +3        QUIT

 +4       ;

EN        ; Entry Point for post-install

 +1        DO BMES^XPDUTL("  Starting post-install for PSO*7*427")

 +2       ;

 +3       ; Removed Cached protocol menus

 +4        DO PROT("PSO REJECT DISPLAY HIDDEN MENU")

 +5        DO PROT("PSO REJECTS HIDDEN ACTIONS #1")

 +6       ;

 +7       ; Update Insurance Pointer in REJECT INFO subfile

 +8        DO INSJOB

 +9       ;

 +10      ; Completion message

 +11       DO BMES^XPDUTL("  Finished post-install for PSO*7*427")

 +12       QUIT

 +13      ;

PROT(MENU) ;

 +1       ; Remove cached hidden menu

 +2        NEW PSOIEN,XQORM

 +3        SET PSOIEN=$ORDER(^ORD(101,"B",MENU,0))

 +4        SET XQORM=PSOIEN_";ORD(101,"

 +5        IF $DATA(^XUTL("XQORM",XQORM))

               Begin DoDot:1

 +6                DO MES^XPDUTL("    Removing cached menu for "_$PIECE(^ORD(101,PSOIEN,0),U))

 +7                KILL ^XUTL("XQORM",XQORM)

               End DoDot:1

 +8        QUIT

 +9       ;

INSJOB    ;

 +1       ; Job the process to update the Reject file

 +2        DO BMES^XPDUTL("    Queuing background job to update the Reject mult of the Prescription file")

 +3        DO MES^XPDUTL("    A Mailman message will be sent when it finishes")

 +4       ;

 +5       ; Setup required variables

 +6        SET ZTRTN="INS^PSO427PS"

           SET ZTIO=""

           SET ZTDTH=$HOROLOG

 +7        SET ZTDESC="Background job to update the Prescription file via PSO*7*427"

 +8       ;

 +9       ; Task the job

 +10       DO ^%ZTLOAD

 +11      ;

 +12      ; Check if task was created

 +13       IF $DATA(ZTSK)

               DO MES^XPDUTL("    Task #"_ZTSK_" queued")

 +14       IF '$DATA(ZTSK)

               DO MES^XPDUTL("   Task not queued.  Please create a support ticket.")

 +15       QUIT

 +16      ;

INS       ;

 +1       ; Entry Point to populate the insurance company pointer in the REJECT INFO subfile

 +2        NEW CNT,DAT,RX,RN,RSPIEN,INS,IEN57,INSNM

 +3        NEW DIE,DA,DR,DTOUT,DUOUT,DIROUT,DIRUT

 +4        SET CNT=0

 +5       ; Loop through index

 +6        SET DAT=0

FOR

               SET DAT=$ORDER(^PSRX("REJDAT",DAT))

               if 'DAT

                   QUIT

               Begin DoDot:1

 +7                SET RX=""

FOR

                       SET RX=$ORDER(^PSRX("REJDAT",DAT,RX))

                       if 'RX

                           QUIT

                       Begin DoDot:2

 +8                        SET RN=""

FOR

                               SET RN=$ORDER(^PSRX("REJDAT",DAT,RX,RN))

                               if 'RN

                                   QUIT

                               Begin DoDot:3

 +9       ;If already populated, quit

 +10                               IF $PIECE($GET(^PSRX(RX,"REJ",RN,2)),"^",9)

                                       QUIT

 +11      ; Get Response pointer

 +12                               SET RSPIEN=$PIECE($GET(^PSRX(RX,"REJ",RN,0)),"^",11)

 +13      ; If the Response pointer exists, get Log of Transaction record and Insurance Pointer from that file

 +14                               SET (IEN57,INS)=""

 +15                               IF RSPIEN

                                       Begin DoDot:4

 +16                                       SET IEN57=$ORDER(^BPSTL("AF",RSPIEN,""))

 +17                                       IF IEN57

                                               SET INS=$$GET1^DIQ(9002313.57902,"1,"_IEN57_",",902.33,"I")

 +18                                       IF INS

                                               IF '$DATA(^DIC(36,INS,0))

                                                   SET INS=""

                                       End DoDot:4

 +19      ; If missing from the Transaction, try to match on the insurance name

 +20      ; There can only be one insurance company with the same name

 +21                               IF INS=""

                                       Begin DoDot:4

 +22                                       SET INSNM=$PIECE($GET(^PSRX(RX,"REJ",RN,2)),"^",4)

 +23                                       IF INSNM]""

                                               SET INS=$ORDER(^DIC(36,"B",INSNM,""))

 +24                                       IF INS

                                               IF $ORDER(^DIC(36,"B",INSNM,INS))

                                                   SET INS=""

                                       End DoDot:4

 +25      ; Quit if there is no insurance

 +26                               IF INS=""

                                       QUIT

 +27      ; Set insurance company into the field

 +28                               SET DIE="^PSRX("_RX_",""REJ"","

                                   SET DA(1)=RX

                                   SET DA=RN

                                   SET DR=33_"////"_INS

 +29                               DO ^DIE

 +30                               KILL DA,DR,DIE

 +31                               SET CNT=CNT+1

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +32      ;

 +33      ; Send email with result

 +34       DO MAIL(CNT)

 +35       QUIT

 +36      ;

MAIL(SUCCNT) ;

 +1        NEW CNT,MSG,XMY,XMDUZ,DIFROM,XMSUB,XMTEXT

 +2        SET XMY(DUZ)=""

 +3        SET XMSUB="PSO*7.0*427 Post install is complete"

           SET XMDUZ="Patch PSO*7.0*427"

 +4        SET XMTEXT="MSG("

 +5        SET CNT=1

           SET MSG(CNT)=""

 +6        SET CNT=CNT+1

           SET MSG(CNT)="Patch PSO*7.0*427 post install routine has completed."

 +7        SET CNT=CNT+1

           SET MSG(CNT)=""

 +8        SET CNT=CNT+1

           SET MSG(CNT)="Updated "_SUCCNT_" records in the PRESCRIPTION file."

 +9        SET CNT=CNT+1

           SET MSG(CNT)=""

 +10       SET CNT=CNT+1

           SET MSG(CNT)="For more information about this post install, review the patch description."

 +11       DO ^XMD

 +12       QUIT

PSO427PS.m