PSO427PS ;ALB/DMB - Post-install for PSO*7*427 ;10/21/2014
;;7.0;OUTPATIENT PHARMACY;**427**;DEC 1997;Build 21
;
Q
;
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")
Q
;
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)
Q
;
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.")
Q
;
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)
Q
;
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSO427PS 3282 printed Sep 23, 2025@19:59:03 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
