- 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 Dec 13, 2024@02:23: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 ;