PSN568PO.m

PSN568PO ;BIR/SJA-Post install routine for patch PSN*4*568 ; 05 Feb 2019 8:40 AM

 ;;4.0;NATIONAL DRUG FILE;**568**; 30 Oct 98;Build 2

 ;

 Q

 ;

EN ; entry point

 N CNT,DATA,II,NODE0,PROD,X

 S CNT=4 K ^TMP("PSN",$J)

 D BMES^XPDUTL("  Starting post-install for PSN*4*568")

 ;

 D BMES^XPDUTL("  Fixing PACKAGE SIZE field for specific NDC/UPN entries....")

 F II=1:1 S DATA=$P($T(@("LIST+"_II_"^PSN568PO")),";;",2) Q:DATA=""  D

 . S NODE0=$G(^PSNDF(50.67,+DATA,0)),PROD=$P($G(^PSNDF(50.68,$P(NODE0,U,6),0)),U)

 . I +$P(NODE0,"^",2)=+$P(DATA,"^",2) S $P(^PSNDF(50.67,+DATA,0),"^",8)=$P(DATA,U,3) D

 . . S CNT=CNT+1,^TMP("PSN",$J,CNT)=+DATA_$J("",12-$L(+DATA))_$P(DATA,U,2)_$J("",17-$L($P(DATA,U,2)))_$E(PROD,1,50)

 D MSG K ^TMP("PSN",$J)

 ;

 K DA,DIC S X="070501092200",DIC="^PSNDF(50.67,",DIC(0)="XM" D ^DIC K DIC

 I '+Y Q

 D BMES^XPDUTL("  Deleting NDC: 070501-0922-00 from the NDC/UPN file(#50.67)")

 K DA,DIK S DA=+Y S DIK="^PSNDF(50.67," D ^DIK K DA,DIK

 ;

 Q

 ;

MSG ; Sends Mailman message about updates

 N XMX,XMSUB,XMDUZ,XMTEXT

 S II=0 F  S II=$O(^XUSEC("PSNMGR",II)) Q:'II  S XMY(II)=""

 S XMY(DUZ)="",XMSUB="PSN*4*568 - PACKAGE SIZE field Update"

 S ^TMP("PSN",$J,1)="The post-install routine fixed the PACKAGE SIZE field value for the following NDC/UPN entries:"

 S ^TMP("PSN",$J,2)=""

 S ^TMP("PSN",$J,3)="NDC IEN #   NDC              VA Product Name"

 S ^TMP("PSN",$J,4)="---------   ------------     ----------------------------"

 S:'$D(^TMP("PSN",$J,5)) ^TMP("PSN",$J,5)="No updates performed."

 S XMDUZ=.5,XMTEXT="^TMP(""PSN"",$J," N DIFROM D ^XMD

 Q

 ;

LIST ; NDC/UPN entries with wrong package size field

 ;;61828^000065002315^4790

 ;;74856^011463070001^4790

 ;;84364^057665000101^4790

 ;;90864^049502018001^4790

 ;;94577^000169776811^4790

 ;;94579^000169777011^4790

 ;;95437^054897000201^4790

 ;;97719^054868495600^4790

 ;;97889^000067315510^4790

 ;;98614^000169770511^4790

 ;;100140^066780011502^4790

 ;;100373^000169770411^4790

 ;;100446^000169770811^4790

 ;;101219^044087111401^4790

 ;;102900^024477002005^4790

 ;;103207^050458056401^4790

 ;;104038^000781318284^4790

 ;;104522^000024582411^4790

 ;;106308^000169770521^4790

 ;;106309^000169770421^4790

 ;;106316^000169770821^4790

 ;;106467^040028051130^49

 ;;107082^000409125401^4790

 ;;114938^000781300144^4790

 ;;114939^000781300126^4790

 ;;114940^000781300107^4790

 ;;114947^054868614600^4790

 ;;122422^035356030602^4790

 ;;123980^010122051001^4790

 ;;126029^000078036964^4790

 ;;126030^054569494700^4790

 ;;126031^000067602415^4790

 ;;147735^000168015408^4790

 ;;154951^068727020002^4790

 ;;154952^068727020001^4790

 ;;154953^067457021102^4790

 ;;154954^039822071001^4790

 ;;154955^010139091015^4790

 ;;154956^000781318273^4790

 ;;203362^044087111701^4790

 ;;205557^050816062401^4790

 ;;215190^000310661502^4790

 ;;216718^000024586903^4790

 ;;225188^004858251201^4790

 ;;226161^054569662500^4790

 ;;230226^000781300407^4790

 ;;235843^000187000402^4790

 ;;235844^000187000400^4790

 ;;236210^000781300426^4790

 ;;237579^000409125411^4790

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PSN568PO   3096     printed  Mar 13, 2025@21:28:20                                                                                                                                                                                                    Page 2

PSN568PO  ;BIR/SJA-Post install routine for patch PSN*4*568 ; 05 Feb 2019 8:40 AM

 +1       ;;4.0;NATIONAL DRUG FILE;**568**; 30 Oct 98;Build 2

 +2       ;

 +3        QUIT 

 +4       ;

EN        ; entry point

 +1        NEW CNT,DATA,II,NODE0,PROD,X

 +2        SET CNT=4

           KILL ^TMP("PSN",$JOB)

 +3        DO BMES^XPDUTL("  Starting post-install for PSN*4*568")

 +4       ;

 +5        DO BMES^XPDUTL("  Fixing PACKAGE SIZE field for specific NDC/UPN entries....")

 +6        FOR II=1:1

               SET DATA=$PIECE($TEXT(@("LIST+"_II_"^PSN568PO")),";;",2)

               if DATA=""

                   QUIT 

               Begin DoDot:1

 +7                SET NODE0=$GET(^PSNDF(50.67,+DATA,0))

                   SET PROD=$PIECE($GET(^PSNDF(50.68,$PIECE(NODE0,U,6),0)),U)

 +8                IF +$PIECE(NODE0,"^",2)=+$PIECE(DATA,"^",2)

                       SET $PIECE(^PSNDF(50.67,+DATA,0),"^",8)=$PIECE(DATA,U,3)

                       Begin DoDot:2

 +9                        SET CNT=CNT+1

                           SET ^TMP("PSN",$JOB,CNT)=+DATA_$JUSTIFY("",12-$LENGTH(+DATA))_$PIECE(DATA,U,2)_$JUSTIFY("",17-$LENGTH($PIECE(DATA,U,2)))_$EXTRACT(PROD,1,50)

                       End DoDot:2

               End DoDot:1

 +10       DO MSG

           KILL ^TMP("PSN",$JOB)

 +11      ;

 +12       KILL DA,DIC

           SET X="070501092200"

           SET DIC="^PSNDF(50.67,"

           SET DIC(0)="XM"

           DO ^DIC

           KILL DIC

 +13       IF '+Y

               QUIT 

 +14       DO BMES^XPDUTL("  Deleting NDC: 070501-0922-00 from the NDC/UPN file(#50.67)")

 +15       KILL DA,DIK

           SET DA=+Y

           SET DIK="^PSNDF(50.67,"

           DO ^DIK

           KILL DA,DIK

 +16      ;

 +17       QUIT 

 +18      ;

MSG       ; Sends Mailman message about updates

 +1        NEW XMX,XMSUB,XMDUZ,XMTEXT

 +2        SET II=0

           FOR 

               SET II=$ORDER(^XUSEC("PSNMGR",II))

               if 'II

                   QUIT 

               SET XMY(II)=""

 +3        SET XMY(DUZ)=""

           SET XMSUB="PSN*4*568 - PACKAGE SIZE field Update"

 +4        SET ^TMP("PSN",$JOB,1)="The post-install routine fixed the PACKAGE SIZE field value for the following NDC/UPN entries:"

 +5        SET ^TMP("PSN",$JOB,2)=""

 +6        SET ^TMP("PSN",$JOB,3)="NDC IEN #   NDC              VA Product Name"

 +7        SET ^TMP("PSN",$JOB,4)="---------   ------------     ----------------------------"

 +8        if '$DATA(^TMP("PSN",$JOB,5))

               SET ^TMP("PSN",$JOB,5)="No updates performed."

 +9        SET XMDUZ=.5

           SET XMTEXT="^TMP(""PSN"",$J,"

           NEW DIFROM

           DO ^XMD

 +10       QUIT 

 +11      ;

LIST      ; NDC/UPN entries with wrong package size field

 +1       ;;61828^000065002315^4790

 +2       ;;74856^011463070001^4790

 +3       ;;84364^057665000101^4790

 +4       ;;90864^049502018001^4790

 +5       ;;94577^000169776811^4790

 +6       ;;94579^000169777011^4790

 +7       ;;95437^054897000201^4790

 +8       ;;97719^054868495600^4790

 +9       ;;97889^000067315510^4790

 +10      ;;98614^000169770511^4790

 +11      ;;100140^066780011502^4790

 +12      ;;100373^000169770411^4790

 +13      ;;100446^000169770811^4790

 +14      ;;101219^044087111401^4790

 +15      ;;102900^024477002005^4790

 +16      ;;103207^050458056401^4790

 +17      ;;104038^000781318284^4790

 +18      ;;104522^000024582411^4790

 +19      ;;106308^000169770521^4790

 +20      ;;106309^000169770421^4790

 +21      ;;106316^000169770821^4790

 +22      ;;106467^040028051130^49

 +23      ;;107082^000409125401^4790

 +24      ;;114938^000781300144^4790

 +25      ;;114939^000781300126^4790

 +26      ;;114940^000781300107^4790

 +27      ;;114947^054868614600^4790

 +28      ;;122422^035356030602^4790

 +29      ;;123980^010122051001^4790

 +30      ;;126029^000078036964^4790

 +31      ;;126030^054569494700^4790

 +32      ;;126031^000067602415^4790

 +33      ;;147735^000168015408^4790

 +34      ;;154951^068727020002^4790

 +35      ;;154952^068727020001^4790

 +36      ;;154953^067457021102^4790

 +37      ;;154954^039822071001^4790

 +38      ;;154955^010139091015^4790

 +39      ;;154956^000781318273^4790

 +40      ;;203362^044087111701^4790

 +41      ;;205557^050816062401^4790

 +42      ;;215190^000310661502^4790

 +43      ;;216718^000024586903^4790

 +44      ;;225188^004858251201^4790

 +45      ;;226161^054569662500^4790

 +46      ;;230226^000781300407^4790

 +47      ;;235843^000187000402^4790

 +48      ;;235844^000187000400^4790

 +49      ;;236210^000781300426^4790

 +50      ;;237579^000409125411^4790

 +51      ;