PSN574P ;HDSO/DSK - PSN*4.0*574 Post-install routine; Aug 11, 2022@15:00
;;4.0;NATIONAL DRUG FILE;**574**; 30 Oct 98;Build 5
;
; Reference to ^GMR(120.8 in ICR #2545
; Reference to ^GMR(120.8 in ICR #905
; (ICR #2545 pertains to write access.)
; (ICR #905 pertains to read access.)
Q
;
EN ;
;This post-install routine for PSN*4.0*574 will:
;
;1. Correct a "ORPHENADRINE" entry in the NDC/UPN (#50.67) file
; which has the TRADE NAME (#4) field defined as "COFLEX".
;
;2. Update records in the PATIENT ALLERGIES (#120.8) file which
; are defined as against "ORPHENADRINE" but the entry in the
; REACTANT (#.02) field is defined with "COFLEX".
;
;This routine is not deleted after install since it is tasked.
;A future patch will delete the routine.
;
N PSNDUZ,ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTSAVE
S ZTRTN="START^PSN574P"
S ZTDESC="PSN*4.0*574 Post-Install Routine"
S ZTIO="",ZTDTH=$H
S PSNDUZ=DUZ
S ZTSAVE("PSNDUZ")=""
D ^%ZTLOAD
D BMES^XPDUTL($$CJ^XLFSTR("PSN*4.0*574 Post-Install Routine has been tasked.",80))
D BMES^XPDUTL($$CJ^XLFSTR("Task Number: "_$G(ZTSK),80))
D BMES^XPDUTL($$CJ^XLFSTR("You as well as holders of the PSNMGR security key will receive",80))
D BMES^XPDUTL($$CJ^XLFSTR("a MailMan message when the search completes.",80))
Q
;
START ;
;Killing ^XTMP in case routine is run more than once during testing.
K ^XTMP("PSN*4.0*574 POST INSTALL")
S ^XTMP("PSN*4.0*574 POST INSTALL",0)=$$FMADD^XLFDT(DT,90)_"^"_DT_"^PSN*4.0*574 POST INSTALL"
;
N PSNMAILSQ,PSNSPACE
F PSNMAILSQ=1:1:50 S PSNSPACE=$G(PSNSPACE)_" "
D NDCUPN,GMR,MAIL
S:$D(ZTQUEUED) ZTREQ="@"
Q
;
NDCUPN ;Correct entries in the NDC/UPN (#50.67) file.
S ^XTMP("PSN*4.0*574 POST INSTALL",1)=" "
S ^XTMP("PSN*4.0*574 POST INSTALL",2)="The following entries in the NDC/UPN (#50.67) file have been corrected"
S ^XTMP("PSN*4.0*574 POST INSTALL",3)="to replace the TRADE NAME (#4) field entry of ""COFLEX"" with"
S ^XTMP("PSN*4.0*574 POST INSTALL",4)="""ORPHENADRINE CITRATE""."
S ^XTMP("PSN*4.0*574 POST INSTALL",5)=" "
S ^XTMP("PSN*4.0*574 POST INSTALL",6)="NDC/UPN (#50.67)"
S ^XTMP("PSN*4.0*574 POST INSTALL",7)="FILE IEN NDC VA PRODUCT NAME"
S ^XTMP("PSN*4.0*574 POST INSTALL",8)="---------------- ------------ ------------------------------"
;Following line will be overwritten if corrections are made.
S ^XTMP("PSN*4.0*574 POST INSTALL",9)="No entries were found which needed correction."
;
N DIE,DR,DA,PSNX,PSNSTR
S DIE="^PSNDF(50.67,",DR="4////ORPHENADRINE CITRATE"
S (PSNX,PSNSTR)="",PSNMAILSQ=9
F S PSNX=$O(^PSNDF(50.67,"T","COFLEX",PSNX)) Q:PSNX="" D
. ;Double check:
. Q:$$GET1^DIQ(50.67,PSNX,4)'="COFLEX"
. ;Triple check:
. Q:$$GET1^DIQ(50.67,PSNX,5)'["ORPHENADRINE CITRATE"
. S DA=PSNX
. D ^DIE
. S ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ)=PSNX_$E(PSNSPACE,1,18-$L(PSNX))_$$GET1^DIQ(50.67,PSNX,1)
. S PSNSTR=$L(^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ))
. S ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ)=^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ)_$E(PSNSPACE,1,32-PSNSTR)
. S ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ)=^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ)_$E($$GET1^DIQ(50.67,PSNX,5),1,30)
. S PSNMAILSQ=PSNMAILSQ+1
;Adjust if entries were corrected.
I PSNMAILSQ>9 S PSNMAILSQ=PSNMAILSQ-1
Q
;
GMR ;Correct records in the PATIENT ALLERGIES (#120.8) file.
;Adding extra spacing for readability of message.
S ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+1)=" "
S ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+2)="The following entries in the PATIENT ALLERGIES (#120.8) file have been"
S ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+3)="corrected to replace the REACTANT (#.02) field entry of ""COFLEX"" with"
S ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+4)="""ORPHENADRINE CITRATE"". (The replacement is performed only if the"
S ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+5)="GMR ALLERGIES (#1) field entry equals ""ORPHENADRINE CITRATE"".)"
S ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+6)=" "
S ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+7)="****************************************************************"
S ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+8)="* It is recommended that the patients on this report have *"
S ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+9)="* their charts reviewed for accuracy. *"
S ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+10)="****************************************************************"
S ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+11)=" "
S ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+12)=" 1st LETTER PATIENT ALLERGIES PATIENT ALLERGIES"
S ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+13)="PATIENT (#2) LAST NAME ORIGINATION (#120.8) FILE"
S ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+14)="FILE IEN LAST 4 SSN DATE/TIME IEN"
S ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+15)="-------------- ---------- ------------------ ------------------"
;Following line will be overwritten if corrections are made.
S ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+16)="No entries were found which needed correction."
;
N DIE,DR,DA,PSNX,PSNSTART,DFN,VADM,PSNL4,PSNSTR,PSNORIG
S DIE="^GMR(120.8,",DR=".02////ORPHENADRINE CITRATE"
S PSNX="",(PSNSTART,PSNMAILSQ)=PSNMAILSQ+16
F S PSNX=$O(^GMR(120.8,"C","COFLEX",PSNX)) Q:PSNX="" D
. ;Double check:
. Q:$$GET1^DIQ(120.8,PSNX,.02)'="COFLEX"
. ;Triple check:
. Q:$$GET1^DIQ(120.8,PSNX,1)'="ORPHENADRINE CITRATE"
. S DA=PSNX
. D ^DIE
. ;File 2 IEN for patient
. S DFN=$$GET1^DIQ(120.8,PSNX,.01,"I")
. D DEM^VADPT
. ;PSNL4 = First letter of last name_last four of SSN
. S PSNL4=$E(VADM(1))_$P(VADM(2),"-",3)
. S ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ)=DFN_$E(PSNSPACE,1,16-$L(DFN))_PSNL4
. ;Origination date/time of allergy.
. S PSNORIG=$P($$GET1^DIQ(120.8,PSNX,4),":",1,2)
. S PSNSTR=$L(^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ))
. S ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ)=^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ)_$E(PSNSPACE,1,28-PSNSTR)
. S ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ)=^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ)_PSNORIG
. ;File 120.8 IEN
. S PSNSTR=$L(^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ))
. S ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ)=^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ)_$E(PSNSPACE,1,48-PSNSTR)
. S ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ)=^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ)_PSNX
. S PSNMAILSQ=PSNMAILSQ+1
;Adjust if entries were corrected.
I PSNMAILSQ'=PSNSTART S PSNMAILSQ=PSNMAILSQ-1
Q
;
MAIL ;
N PSNREC,PSNTEXT,PSNMY,PSNSUB,PSNMIN
S ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+1)=" "
S ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+2)="Information pertaining to each modified entry will be stored in the global"
S ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+3)="^XTMP(""PSN*4.0*574 POST INSTALL"" for 90 days."
S PSNTEXT="^XTMP(""PSN*4.0*574 POST INSTALL"")"
S PSNREC=""
F S PSNREC=$O(^XUSEC("PSNMGR",PSNREC)) Q:PSNREC="" D
. S PSNMY(PSNREC)=""
S PSNMY(PSNDUZ)=""
S PSNSUB="PSN*4.0*574 Post-Install Information"
S PSNMIN("FROM")="PSN*4.0*574 Post-Install"
D SENDMSG^XMXAPI(PSNDUZ,PSNSUB,PSNTEXT,.PSNMY,.PSNMIN,"","")
Q
;
BACKOUT ;This section is invoked from the programmer's prompt if patch back out is required.
N DIR,Y
S DIR("A",1)="This action will back out the file modifications that were performed"
S DIR("A",2)="after the install of PSN*4.0*574."
S DIR("A")="Are you sure you wish to proceed",DIR("B")="NO",DIR(0)="Y"
D ^DIR
Q:Y<1
;Killing ^XTMP in case routine is run more than once during testing.
K ^XTMP("PSN*4.0*574 BACK OUT")
S ^XTMP("PSN*4.0*574 BACK OUT",0)=$$FMADD^XLFDT(DT,90)_"^"_DT_"^PSN*4.0*574 BACK OUT"
S ^XTMP("PSN*4.0*574 BACK OUT",1)=" "
S ^XTMP("PSN*4.0*574 BACK OUT",2)="Patch PSN*4.0*574 was backed out by "_$$GET1^DIQ(200,DUZ,.01)_"."
S ^XTMP("PSN*4.0*574 BACK OUT",3)=" "
;
N PSNMAILSQ,PSNSPACE,PSNZ
F PSNMAILSQ=1:1:50 S PSNSPACE=$G(PSNSPACE)_" "
W !!,"Please wait until the back out completes."
W !,"Working."
D NDCBACK,GMRBACK,MAILBACK
Q
;
NDCBACK ;
S ^XTMP("PSN*4.0*574 BACK OUT",4)="The following entries in the NDC/UPN (#50.67) file have been restored"
S ^XTMP("PSN*4.0*574 BACK OUT",5)="to replace the TRADE NAME (#4) field entry of ""ORPHENADRINE CITRATE"""
S ^XTMP("PSN*4.0*574 BACK OUT",6)="with ""COFLEX""."
S ^XTMP("PSN*4.0*574 BACK OUT",7)=" "
S ^XTMP("PSN*4.0*574 BACK OUT",8)="NDC/UPN (#50.67)"
S ^XTMP("PSN*4.0*574 BACK OUT",9)="FILE IEN NDC VA PRODUCT NAME"
S ^XTMP("PSN*4.0*574 BACK OUT",10)="---------------- ------------ ------------------------------"
;Following line will be overwritten if corrections are made.
S ^XTMP("PSN*4.0*574 BACK OUT",11)="No entries were found which needed to be backed out."
;
N DIE,DR,DA,PSNX,PSNQUIT,PSNSTR
S DIE="^PSNDF(50.67,",DR="4////COFLEX"
S PSNQUIT=0,PSNSTR="",PSNZ=8,PSNMAILSQ=11
;Sites should only have one entry that was corrected, but looping just in case.
F S PSNZ=$O(^XTMP("PSN*4.0*574 POST INSTALL",PSNZ)) Q:PSNZ="" Q:PSNQUIT D
. S PSNX=$P(^XTMP("PSN*4.0*574 POST INSTALL",PSNZ)," ")
. I PSNX="" S PSNQUIT=1 Q
. ;Double check:
. Q:$$GET1^DIQ(50.67,PSNX,4)'="ORPHENADRINE CITRATE"
. ;Triple check:
. Q:$$GET1^DIQ(50.67,PSNX,5)'["ORPHENADRINE CITRATE"
. S DA=PSNX
. D ^DIE
. S ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ)=PSNX_$E(PSNSPACE,1,18-$L(PSNX))_$$GET1^DIQ(50.67,PSNX,1)
. S PSNSTR=$L(^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ))
. S ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ)=^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ)_$E(PSNSPACE,1,32-PSNSTR)
. S ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ)=^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ)_$E($$GET1^DIQ(50.67,PSNX,5),1,33)
. S PSNMAILSQ=PSNMAILSQ+1
. W "."
;Adjust if entries were backed out.
I PSNMAILSQ>11 S PSNMAILSQ=PSNMAILSQ-1
Q
;
GMRBACK ;
S ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ+1)=" "
S ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ+2)="The following entries in the PATIENT ALLERGIES (#120.8) file have been"
S ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ+3)="restored to replace the REACTANT (#.02) field entry of ""ORPHENADRINE"""
S ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ+4)="""CITRATE"" with ""COFLEX"". (The replacement is only performed if the entry"
S ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ+5)="was modified by the PSN*4.0*574 patch post-install.)"
S ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ+6)=" "
S ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ+7)=" 1st LETTER PATIENT ALLERGIES PATIENT ALLERGIES"
S ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ+8)="PATIENT (#2) LAST NAME ORIGINATION (#120.8) FILE"
S ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ+9)="FILE IEN LAST 4 SSN DATE/TIME IEN"
S ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ+10)="-------------- ---------- ------------------ ------------------"
;Following line will be overwritten if corrections are made.
S ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ+11)="No entries were found which needed to be backed out."
;
N DIE,DR,DA,PSNX,PSNSTART,PSNQUIT,PSNSTR,PSNCOUNT,PSNCHAR,DFN,PSNL4
S DIE="^GMR(120.8,",DR=".02////COFLEX"
;First file 120.8 correction will be 16 lines ahead in the MailMan message.
S PSNZ=PSNZ+12,(PSNMAILSQ,PSNSTART)=PSNMAILSQ+11,PSNQUIT=0
F S PSNZ=$O(^XTMP("PSN*4.0*574 POST INSTALL",PSNZ)) Q:PSNZ="" Q:PSNQUIT D
. ;Need to pluck out the entry at the end of the string.
. S PSNSTR=^XTMP("PSN*4.0*574 POST INSTALL",PSNZ)
. I PSNSTR=" " S PSNQUIT=1 Q
. S PSNX=""
. F PSNCOUNT=0:1 S PSNCHAR=$E(PSNSTR,$L(PSNSTR)-PSNCOUNT) Q:PSNCHAR=" " S PSNX=PSNCHAR_PSNX
. ;Double check:
. Q:$$GET1^DIQ(120.8,PSNX,.02)'="ORPHENADRINE CITRATE"
. ;Double check again:
. Q:$$GET1^DIQ(120.8,PSNX,1)'="ORPHENADRINE CITRATE"
. S DA=PSNX
. D ^DIE
. S DFN=$$GET1^DIQ(120.8,PSNX,.01,"I")
. D DEM^VADPT
. ;PSNL4 = First letter of last name_last four of SSN
. S PSNL4=$E(VADM(1))_$P(VADM(2),"-",3)
. S ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ)=DFN_$E(PSNSPACE,1,16-$L(DFN))_PSNL4
. ;Origination date/time of allergy.
. S PSNORIG=$P($$GET1^DIQ(120.8,PSNX,4),":",1,2)
. S PSNSTR=$L(^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ))
. S ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ)=^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ)_$E(PSNSPACE,1,28-PSNSTR)
. S ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ)=^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ)_PSNORIG
. ;File 120.8 IEN
. S PSNSTR=$L(^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ))
. S ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ)=^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ)_$E(PSNSPACE,1,48-PSNSTR)
. S ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ)=^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ)_PSNX
. S PSNMAILSQ=PSNMAILSQ+1
. W "."
;Adjust if entries were backed out.
I PSNMAILSQ'=PSNSTART S PSNMAILSQ=PSNMAILSQ-1
W !,"Finished back out. Now queueing MailMan message.",!
Q
MAILBACK ;
N PSNREC,PSNTEXT,PSNMY,PSNSUB,PSNMIN,PSNMZ,DIR
S ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ+1)=" "
S ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ+2)="The text of this message will be stored in the global"
S ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ+3)="^XTMP(""PSN*4.0*574 BACK OUT"" for 90 days."
S PSNTEXT="^XTMP(""PSN*4.0*574 BACK OUT"")"
S PSNREC=""
F S PSNREC=$O(^XUSEC("PSNMGR",PSNREC)) Q:PSNREC="" D
. S PSNMY(PSNREC)=""
S PSNMY(DUZ)=""
S PSNSUB="PSN*4.0*574 Back Out Information"
S PSNMIN("FROM")="PSN*4.0*574 BACK OUT"
D SENDMSG^XMXAPI(DUZ,PSNSUB,PSNTEXT,.PSNMY,.PSNMIN,.PSNMZ,"")
S DIR("A",1)="MailMan message #"_PSNMZ_" has been sent to you as well as"
S DIR("A",2)="holders of the PSNMGR security key."
S DIR("A")="Press any key to continue"
S DIR(0)="E"
D ^DIR
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSN574P 13808 printed Sep 23, 2025@19:59:37 Page 2
PSN574P ;HDSO/DSK - PSN*4.0*574 Post-install routine; Aug 11, 2022@15:00
+1 ;;4.0;NATIONAL DRUG FILE;**574**; 30 Oct 98;Build 5
+2 ;
+3 ; Reference to ^GMR(120.8 in ICR #2545
+4 ; Reference to ^GMR(120.8 in ICR #905
+5 ; (ICR #2545 pertains to write access.)
+6 ; (ICR #905 pertains to read access.)
+7 QUIT
+8 ;
EN ;
+1 ;This post-install routine for PSN*4.0*574 will:
+2 ;
+3 ;1. Correct a "ORPHENADRINE" entry in the NDC/UPN (#50.67) file
+4 ; which has the TRADE NAME (#4) field defined as "COFLEX".
+5 ;
+6 ;2. Update records in the PATIENT ALLERGIES (#120.8) file which
+7 ; are defined as against "ORPHENADRINE" but the entry in the
+8 ; REACTANT (#.02) field is defined with "COFLEX".
+9 ;
+10 ;This routine is not deleted after install since it is tasked.
+11 ;A future patch will delete the routine.
+12 ;
+13 NEW PSNDUZ,ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTSAVE
+14 SET ZTRTN="START^PSN574P"
+15 SET ZTDESC="PSN*4.0*574 Post-Install Routine"
+16 SET ZTIO=""
SET ZTDTH=$HOROLOG
+17 SET PSNDUZ=DUZ
+18 SET ZTSAVE("PSNDUZ")=""
+19 DO ^%ZTLOAD
+20 DO BMES^XPDUTL($$CJ^XLFSTR("PSN*4.0*574 Post-Install Routine has been tasked.",80))
+21 DO BMES^XPDUTL($$CJ^XLFSTR("Task Number: "_$GET(ZTSK),80))
+22 DO BMES^XPDUTL($$CJ^XLFSTR("You as well as holders of the PSNMGR security key will receive",80))
+23 DO BMES^XPDUTL($$CJ^XLFSTR("a MailMan message when the search completes.",80))
+24 QUIT
+25 ;
START ;
+1 ;Killing ^XTMP in case routine is run more than once during testing.
+2 KILL ^XTMP("PSN*4.0*574 POST INSTALL")
+3 SET ^XTMP("PSN*4.0*574 POST INSTALL",0)=$$FMADD^XLFDT(DT,90)_"^"_DT_"^PSN*4.0*574 POST INSTALL"
+4 ;
+5 NEW PSNMAILSQ,PSNSPACE
+6 FOR PSNMAILSQ=1:1:50
SET PSNSPACE=$GET(PSNSPACE)_" "
+7 DO NDCUPN
DO GMR
DO MAIL
+8 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+9 QUIT
+10 ;
NDCUPN ;Correct entries in the NDC/UPN (#50.67) file.
+1 SET ^XTMP("PSN*4.0*574 POST INSTALL",1)=" "
+2 SET ^XTMP("PSN*4.0*574 POST INSTALL",2)="The following entries in the NDC/UPN (#50.67) file have been corrected"
+3 SET ^XTMP("PSN*4.0*574 POST INSTALL",3)="to replace the TRADE NAME (#4) field entry of ""COFLEX"" with"
+4 SET ^XTMP("PSN*4.0*574 POST INSTALL",4)="""ORPHENADRINE CITRATE""."
+5 SET ^XTMP("PSN*4.0*574 POST INSTALL",5)=" "
+6 SET ^XTMP("PSN*4.0*574 POST INSTALL",6)="NDC/UPN (#50.67)"
+7 SET ^XTMP("PSN*4.0*574 POST INSTALL",7)="FILE IEN NDC VA PRODUCT NAME"
+8 SET ^XTMP("PSN*4.0*574 POST INSTALL",8)="---------------- ------------ ------------------------------"
+9 ;Following line will be overwritten if corrections are made.
+10 SET ^XTMP("PSN*4.0*574 POST INSTALL",9)="No entries were found which needed correction."
+11 ;
+12 NEW DIE,DR,DA,PSNX,PSNSTR
+13 SET DIE="^PSNDF(50.67,"
SET DR="4////ORPHENADRINE CITRATE"
+14 SET (PSNX,PSNSTR)=""
SET PSNMAILSQ=9
+15 FOR
SET PSNX=$ORDER(^PSNDF(50.67,"T","COFLEX",PSNX))
if PSNX=""
QUIT
Begin DoDot:1
+16 ;Double check:
+17 if $$GET1^DIQ(50.67,PSNX,4)'="COFLEX"
QUIT
+18 ;Triple check:
+19 if $$GET1^DIQ(50.67,PSNX,5)'["ORPHENADRINE CITRATE"
QUIT
+20 SET DA=PSNX
+21 DO ^DIE
+22 SET ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ)=PSNX_$EXTRACT(PSNSPACE,1,18-$LENGTH(PSNX))_$$GET1^DIQ(50.67,PSNX,1)
+23 SET PSNSTR=$LENGTH(^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ))
+24 SET ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ)=^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ)_$EXTRACT(PSNSPACE,1,32-PSNSTR)
+25 SET ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ)=^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ)_$EXTRACT($$GET1^DIQ(50.67,PSNX,5),1,30)
+26 SET PSNMAILSQ=PSNMAILSQ+1
End DoDot:1
+27 ;Adjust if entries were corrected.
+28 IF PSNMAILSQ>9
SET PSNMAILSQ=PSNMAILSQ-1
+29 QUIT
+30 ;
GMR ;Correct records in the PATIENT ALLERGIES (#120.8) file.
+1 ;Adding extra spacing for readability of message.
+2 SET ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+1)=" "
+3 SET ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+2)="The following entries in the PATIENT ALLERGIES (#120.8) file have been"
+4 SET ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+3)="corrected to replace the REACTANT (#.02) field entry of ""COFLEX"" with"
+5 SET ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+4)="""ORPHENADRINE CITRATE"". (The replacement is performed only if the"
+6 SET ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+5)="GMR ALLERGIES (#1) field entry equals ""ORPHENADRINE CITRATE"".)"
+7 SET ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+6)=" "
+8 SET ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+7)="****************************************************************"
+9 SET ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+8)="* It is recommended that the patients on this report have *"
+10 SET ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+9)="* their charts reviewed for accuracy. *"
+11 SET ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+10)="****************************************************************"
+12 SET ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+11)=" "
+13 SET ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+12)=" 1st LETTER PATIENT ALLERGIES PATIENT ALLERGIES"
+14 SET ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+13)="PATIENT (#2) LAST NAME ORIGINATION (#120.8) FILE"
+15 SET ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+14)="FILE IEN LAST 4 SSN DATE/TIME IEN"
+16 SET ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+15)="-------------- ---------- ------------------ ------------------"
+17 ;Following line will be overwritten if corrections are made.
+18 SET ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+16)="No entries were found which needed correction."
+19 ;
+20 NEW DIE,DR,DA,PSNX,PSNSTART,DFN,VADM,PSNL4,PSNSTR,PSNORIG
+21 SET DIE="^GMR(120.8,"
SET DR=".02////ORPHENADRINE CITRATE"
+22 SET PSNX=""
SET (PSNSTART,PSNMAILSQ)=PSNMAILSQ+16
+23 FOR
SET PSNX=$ORDER(^GMR(120.8,"C","COFLEX",PSNX))
if PSNX=""
QUIT
Begin DoDot:1
+24 ;Double check:
+25 if $$GET1^DIQ(120.8,PSNX,.02)'="COFLEX"
QUIT
+26 ;Triple check:
+27 if $$GET1^DIQ(120.8,PSNX,1)'="ORPHENADRINE CITRATE"
QUIT
+28 SET DA=PSNX
+29 DO ^DIE
+30 ;File 2 IEN for patient
+31 SET DFN=$$GET1^DIQ(120.8,PSNX,.01,"I")
+32 DO DEM^VADPT
+33 ;PSNL4 = First letter of last name_last four of SSN
+34 SET PSNL4=$EXTRACT(VADM(1))_$PIECE(VADM(2),"-",3)
+35 SET ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ)=DFN_$EXTRACT(PSNSPACE,1,16-$LENGTH(DFN))_PSNL4
+36 ;Origination date/time of allergy.
+37 SET PSNORIG=$PIECE($$GET1^DIQ(120.8,PSNX,4),":",1,2)
+38 SET PSNSTR=$LENGTH(^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ))
+39 SET ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ)=^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ)_$EXTRACT(PSNSPACE,1,28-PSNSTR)
+40 SET ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ)=^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ)_PSNORIG
+41 ;File 120.8 IEN
+42 SET PSNSTR=$LENGTH(^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ))
+43 SET ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ)=^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ)_$EXTRACT(PSNSPACE,1,48-PSNSTR)
+44 SET ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ)=^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ)_PSNX
+45 SET PSNMAILSQ=PSNMAILSQ+1
End DoDot:1
+46 ;Adjust if entries were corrected.
+47 IF PSNMAILSQ'=PSNSTART
SET PSNMAILSQ=PSNMAILSQ-1
+48 QUIT
+49 ;
MAIL ;
+1 NEW PSNREC,PSNTEXT,PSNMY,PSNSUB,PSNMIN
+2 SET ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+1)=" "
+3 SET ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+2)="Information pertaining to each modified entry will be stored in the global"
+4 SET ^XTMP("PSN*4.0*574 POST INSTALL",PSNMAILSQ+3)="^XTMP(""PSN*4.0*574 POST INSTALL"" for 90 days."
+5 SET PSNTEXT="^XTMP(""PSN*4.0*574 POST INSTALL"")"
+6 SET PSNREC=""
+7 FOR
SET PSNREC=$ORDER(^XUSEC("PSNMGR",PSNREC))
if PSNREC=""
QUIT
Begin DoDot:1
+8 SET PSNMY(PSNREC)=""
End DoDot:1
+9 SET PSNMY(PSNDUZ)=""
+10 SET PSNSUB="PSN*4.0*574 Post-Install Information"
+11 SET PSNMIN("FROM")="PSN*4.0*574 Post-Install"
+12 DO SENDMSG^XMXAPI(PSNDUZ,PSNSUB,PSNTEXT,.PSNMY,.PSNMIN,"","")
+13 QUIT
+14 ;
BACKOUT ;This section is invoked from the programmer's prompt if patch back out is required.
+1 NEW DIR,Y
+2 SET DIR("A",1)="This action will back out the file modifications that were performed"
+3 SET DIR("A",2)="after the install of PSN*4.0*574."
+4 SET DIR("A")="Are you sure you wish to proceed"
SET DIR("B")="NO"
SET DIR(0)="Y"
+5 DO ^DIR
+6 if Y<1
QUIT
+7 ;Killing ^XTMP in case routine is run more than once during testing.
+8 KILL ^XTMP("PSN*4.0*574 BACK OUT")
+9 SET ^XTMP("PSN*4.0*574 BACK OUT",0)=$$FMADD^XLFDT(DT,90)_"^"_DT_"^PSN*4.0*574 BACK OUT"
+10 SET ^XTMP("PSN*4.0*574 BACK OUT",1)=" "
+11 SET ^XTMP("PSN*4.0*574 BACK OUT",2)="Patch PSN*4.0*574 was backed out by "_$$GET1^DIQ(200,DUZ,.01)_"."
+12 SET ^XTMP("PSN*4.0*574 BACK OUT",3)=" "
+13 ;
+14 NEW PSNMAILSQ,PSNSPACE,PSNZ
+15 FOR PSNMAILSQ=1:1:50
SET PSNSPACE=$GET(PSNSPACE)_" "
+16 WRITE !!,"Please wait until the back out completes."
+17 WRITE !,"Working."
+18 DO NDCBACK
DO GMRBACK
DO MAILBACK
+19 QUIT
+20 ;
NDCBACK ;
+1 SET ^XTMP("PSN*4.0*574 BACK OUT",4)="The following entries in the NDC/UPN (#50.67) file have been restored"
+2 SET ^XTMP("PSN*4.0*574 BACK OUT",5)="to replace the TRADE NAME (#4) field entry of ""ORPHENADRINE CITRATE"""
+3 SET ^XTMP("PSN*4.0*574 BACK OUT",6)="with ""COFLEX""."
+4 SET ^XTMP("PSN*4.0*574 BACK OUT",7)=" "
+5 SET ^XTMP("PSN*4.0*574 BACK OUT",8)="NDC/UPN (#50.67)"
+6 SET ^XTMP("PSN*4.0*574 BACK OUT",9)="FILE IEN NDC VA PRODUCT NAME"
+7 SET ^XTMP("PSN*4.0*574 BACK OUT",10)="---------------- ------------ ------------------------------"
+8 ;Following line will be overwritten if corrections are made.
+9 SET ^XTMP("PSN*4.0*574 BACK OUT",11)="No entries were found which needed to be backed out."
+10 ;
+11 NEW DIE,DR,DA,PSNX,PSNQUIT,PSNSTR
+12 SET DIE="^PSNDF(50.67,"
SET DR="4////COFLEX"
+13 SET PSNQUIT=0
SET PSNSTR=""
SET PSNZ=8
SET PSNMAILSQ=11
+14 ;Sites should only have one entry that was corrected, but looping just in case.
+15 FOR
SET PSNZ=$ORDER(^XTMP("PSN*4.0*574 POST INSTALL",PSNZ))
if PSNZ=""
QUIT
if PSNQUIT
QUIT
Begin DoDot:1
+16 SET PSNX=$PIECE(^XTMP("PSN*4.0*574 POST INSTALL",PSNZ)," ")
+17 IF PSNX=""
SET PSNQUIT=1
QUIT
+18 ;Double check:
+19 if $$GET1^DIQ(50.67,PSNX,4)'="ORPHENADRINE CITRATE"
QUIT
+20 ;Triple check:
+21 if $$GET1^DIQ(50.67,PSNX,5)'["ORPHENADRINE CITRATE"
QUIT
+22 SET DA=PSNX
+23 DO ^DIE
+24 SET ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ)=PSNX_$EXTRACT(PSNSPACE,1,18-$LENGTH(PSNX))_$$GET1^DIQ(50.67,PSNX,1)
+25 SET PSNSTR=$LENGTH(^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ))
+26 SET ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ)=^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ)_$EXTRACT(PSNSPACE,1,32-PSNSTR)
+27 SET ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ)=^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ)_$EXTRACT($$GET1^DIQ(50.67,PSNX,5),1,33)
+28 SET PSNMAILSQ=PSNMAILSQ+1
+29 WRITE "."
End DoDot:1
+30 ;Adjust if entries were backed out.
+31 IF PSNMAILSQ>11
SET PSNMAILSQ=PSNMAILSQ-1
+32 QUIT
+33 ;
GMRBACK ;
+1 SET ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ+1)=" "
+2 SET ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ+2)="The following entries in the PATIENT ALLERGIES (#120.8) file have been"
+3 SET ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ+3)="restored to replace the REACTANT (#.02) field entry of ""ORPHENADRINE"""
+4 SET ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ+4)="""CITRATE"" with ""COFLEX"". (The replacement is only performed if the entry"
+5 SET ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ+5)="was modified by the PSN*4.0*574 patch post-install.)"
+6 SET ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ+6)=" "
+7 SET ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ+7)=" 1st LETTER PATIENT ALLERGIES PATIENT ALLERGIES"
+8 SET ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ+8)="PATIENT (#2) LAST NAME ORIGINATION (#120.8) FILE"
+9 SET ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ+9)="FILE IEN LAST 4 SSN DATE/TIME IEN"
+10 SET ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ+10)="-------------- ---------- ------------------ ------------------"
+11 ;Following line will be overwritten if corrections are made.
+12 SET ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ+11)="No entries were found which needed to be backed out."
+13 ;
+14 NEW DIE,DR,DA,PSNX,PSNSTART,PSNQUIT,PSNSTR,PSNCOUNT,PSNCHAR,DFN,PSNL4
+15 SET DIE="^GMR(120.8,"
SET DR=".02////COFLEX"
+16 ;First file 120.8 correction will be 16 lines ahead in the MailMan message.
+17 SET PSNZ=PSNZ+12
SET (PSNMAILSQ,PSNSTART)=PSNMAILSQ+11
SET PSNQUIT=0
+18 FOR
SET PSNZ=$ORDER(^XTMP("PSN*4.0*574 POST INSTALL",PSNZ))
if PSNZ=""
QUIT
if PSNQUIT
QUIT
Begin DoDot:1
+19 ;Need to pluck out the entry at the end of the string.
+20 SET PSNSTR=^XTMP("PSN*4.0*574 POST INSTALL",PSNZ)
+21 IF PSNSTR=" "
SET PSNQUIT=1
QUIT
+22 SET PSNX=""
+23 FOR PSNCOUNT=0:1
SET PSNCHAR=$EXTRACT(PSNSTR,$LENGTH(PSNSTR)-PSNCOUNT)
if PSNCHAR=" "
QUIT
SET PSNX=PSNCHAR_PSNX
+24 ;Double check:
+25 if $$GET1^DIQ(120.8,PSNX,.02)'="ORPHENADRINE CITRATE"
QUIT
+26 ;Double check again:
+27 if $$GET1^DIQ(120.8,PSNX,1)'="ORPHENADRINE CITRATE"
QUIT
+28 SET DA=PSNX
+29 DO ^DIE
+30 SET DFN=$$GET1^DIQ(120.8,PSNX,.01,"I")
+31 DO DEM^VADPT
+32 ;PSNL4 = First letter of last name_last four of SSN
+33 SET PSNL4=$EXTRACT(VADM(1))_$PIECE(VADM(2),"-",3)
+34 SET ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ)=DFN_$EXTRACT(PSNSPACE,1,16-$LENGTH(DFN))_PSNL4
+35 ;Origination date/time of allergy.
+36 SET PSNORIG=$PIECE($$GET1^DIQ(120.8,PSNX,4),":",1,2)
+37 SET PSNSTR=$LENGTH(^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ))
+38 SET ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ)=^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ)_$EXTRACT(PSNSPACE,1,28-PSNSTR)
+39 SET ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ)=^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ)_PSNORIG
+40 ;File 120.8 IEN
+41 SET PSNSTR=$LENGTH(^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ))
+42 SET ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ)=^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ)_$EXTRACT(PSNSPACE,1,48-PSNSTR)
+43 SET ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ)=^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ)_PSNX
+44 SET PSNMAILSQ=PSNMAILSQ+1
+45 WRITE "."
End DoDot:1
+46 ;Adjust if entries were backed out.
+47 IF PSNMAILSQ'=PSNSTART
SET PSNMAILSQ=PSNMAILSQ-1
+48 WRITE !,"Finished back out. Now queueing MailMan message.",!
+49 QUIT
MAILBACK ;
+1 NEW PSNREC,PSNTEXT,PSNMY,PSNSUB,PSNMIN,PSNMZ,DIR
+2 SET ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ+1)=" "
+3 SET ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ+2)="The text of this message will be stored in the global"
+4 SET ^XTMP("PSN*4.0*574 BACK OUT",PSNMAILSQ+3)="^XTMP(""PSN*4.0*574 BACK OUT"" for 90 days."
+5 SET PSNTEXT="^XTMP(""PSN*4.0*574 BACK OUT"")"
+6 SET PSNREC=""
+7 FOR
SET PSNREC=$ORDER(^XUSEC("PSNMGR",PSNREC))
if PSNREC=""
QUIT
Begin DoDot:1
+8 SET PSNMY(PSNREC)=""
End DoDot:1
+9 SET PSNMY(DUZ)=""
+10 SET PSNSUB="PSN*4.0*574 Back Out Information"
+11 SET PSNMIN("FROM")="PSN*4.0*574 BACK OUT"
+12 DO SENDMSG^XMXAPI(DUZ,PSNSUB,PSNTEXT,.PSNMY,.PSNMIN,.PSNMZ,"")
+13 SET DIR("A",1)="MailMan message #"_PSNMZ_" has been sent to you as well as"
+14 SET DIR("A",2)="holders of the PSNMGR security key."
+15 SET DIR("A")="Press any key to continue"
+16 SET DIR(0)="E"
+17 DO ^DIR
+18 QUIT
+19 ;
