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 ---[H[J[2J[HPSN568PO 3096 printed Dec 13, 2024@02:23:36 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 ;
