Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSN574P

PSN574P.m

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