PSNPPSMS ;HP/LE-PPSN update NDFK ; 05 Mar 2014 1:20 PM
;;4.0;NATIONAL DRUG FILE;**513**; 30 Oct 98;Build 53
;Reference to ^%ZISH supported by DBIA #2320
;
56(FILE,DIA,NEW,PSNTMPN) ;Drug Interaction file (#56) changes into 5000.561
;5000.561 = inactivated drug interactions
;5000.56 = added and edited drug interactions
;
N DIC,DIE,DD,DO,DINUM,DA,FDA,NDFIEN,FLD1,TYPE,PSNPS,STAT
S PSNPS=$P($G(^PS(59.7,1,10)),"^",12) Q:PSNPS'="N"
S FLD1=$P(DIA,"^",3),NDFIEN=+DIA
S STAT="",STAT=$S((FLD1=7&(NEW'="")):"I",PSNTMPN="DATAN":"A",PSNTMPN="DATAO":"E",1:"")
I '$D(^NDFK(5000.56,$P(DIA,"^"))) D
.S DIC="^NDFK(5000.56,",DIC(0)="Z",(X,DINUM)=$P(DIA,"^") D FILE^DICN
.S DIE=DIC,DA=+Y K DIC
.S DA=+$P(DIA,"^"),DIE="^NDFK(5000.56,",DR="1///"_STAT D ^DIE
I $D(^NDFK(5000.56,$P(DIA,"^"))) D
.S DIC="^NDFK(5000.56,",DA=+$P(DIA,"^"),DIE="^NDFK(5000.56,",DR="1///"_STAT D ^DIE
Q
;
IGU ;For National VistA Test SQA use only
;When a PPS-N Update file cannot be installed in the National VistA Test SQA account, use this option to reject the file.
;Local VA production sites or product test accounts should NEVER use this option. If you do, your NDF files
;will be out of sync and may cause irreparable damage. This is for SQA to reject corrupted files before they are nationally released.
N COMM,FILE,ANS,PARAM,ENTER,II,FLG,ACT,TYPE,PSNLEGF,ZTQUEUED,ZTREQ,IOBOFF,IOBON
S (ACT,TYPE,PARAM)="",PARAM=$$GET1^DIQ(59.7,1,17,"I")
;
IGU2 ;
S PSNLEGF="",PSNLEGF=$$LEGACY^PSNPPSDL() I PSNLEGF Q
S TYPE=$S("^P^T^S^"[("^"_PARAM_"^"):"C",1:"CR")
W !!
I TYPE="C" W "Note: Local sites may send completion messages for PPSN Update files, but may" D ;only show for local sites, product support, local site test accounts
.W !,"not utilize the Reject Update File functionality as it is for National QA only.",!!
K DIR S DIR(0)="F^17:40^I X'?1""PPS_""1.12N1""PRV_""1.12N1""NEW.DAT"" K X"
S DIR("A")="Enter the PPS-N data file name to be "_$S(TYPE="CR":"Updated",1:"Completed")
S DIR("?",1)=" Enter the PPS-N Update file name that cannot be installed."
S DIR("?")=" The file format should be PPS_nnPRV_nnNEW.DAT." D ^DIR K DIR S FILE=Y
I (FILE="")!$D(DTOUT)!$D(DUOUT) Q
S (II,FLG)=0 F S II=$O(^PS(57.23,1,4,"B",FILE,II)) Q:'II I $P($G(^PS(57.23,1,4,II,0)),"^",4)]"" S FLG=1
I FLG=0 W !!!,$G(IOBON),"WARNING:",$G(IOBOFF)," The selected file hasn't been downloaded in VistA. It must be ",!,?9,"downloaded before you can be take action.",$C(7) Q
I +$P(FILE,"_",2)'=($$GET1^DIQ(57.23,1,8)-1) W !!!,$G(IOBON),"WARNING:",$G(IOBOFF)," Reject isn't allowed for Update files older than the current",!,?9,"downloaded version",$C(7) R !!,"Enter to continue... ",ENTER:60 Q
;
I TYPE="CR" D ACTION I ACT="^" W !!,"No action taken." Q
S ACT=$S(TYPE="C":"C",1:ACT)
I ACT="C" D D CONT Q
.S COMM="",COMM=$$SEND^PSNPPSNC("COMPLETED",$P(FILE,";"),"") H 1 W !! D
..I COMM=1 W !,"Complete message was sent to PPS-N. File should be approved/rejected ",!,"in PPS-N side.",!
..;E W !,"There was a problem and the data file was not completed in PPS-N side."
..I 'COMM D RETRY
;
RJ ; execute file rejection
N NFF S NFF=$$ASK(FILE) I $O(^PS(57.23,1,"B",$P(FILE,";")_";"_$P(NFF,"^",2),""),-1),PARAM'="Q" W !!,"No action taken." Q
W ! K DIR S DIR("A")="Are you sure you want to reject file '"_FILE_"'",DIR("B")="NO",DIR(0)="Y" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) Q
S ANS=Y I 'ANS W !!,"No action taken." Q
W !
; send message to PPS-N - REJECTED processing
S COMM="",COMM=$$SEND^PSNPPSNC("ERROR",$P(FILE,";"),"Automatically Rejected: Unable to Install Update File in the Test Account") H 1
I 'COMM D G IGU2
.W !?11,"*** ERROR: "_$P(COMM,"^",2)
.W !!?11,"PPS-N did not accept the REJECT transmission for "
.W !?11,FILE_"."
.W !!?11,"Contact your IRM and ask them to validate that the UPDATE_STATUS"
.W !?11,"web service manager is defined under the Web Server Name PPSN"
.W !?11,"and that it is active. Also verify that the Pharmacy Product"
.W !?11,"System-National (PPS-N) is on-line.",!!
I COMM W !!,FILE," has been automatically rejected in PPS-N.",! S $P(^PS(57.23,1,0),"^",7)=+$P(FILE,"_",2) D
.I $P(NFF,"^",2) D REJUPD(FILE_";"_$P(NFF,"^",2))
;
CONT ;
K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to Continue" D ^DIR
Q
ACTION ; prompt user for action type (complete/reject)
I $$ASK1(FILE) S ACT="C" Q
W ! K DIR,ACT S DIR("A")="Action",DIR(0)="S^C:Complete data file;R:Reject data file",DIR("B")="C"
S DIR("?")="Enter 'R' to reject the data file in PPS-N and retain the data for next update file version. Enter 'C' to changes the status in PPS-N which allows the user to notify PPS-N that the installation completed."
D ^DIR S ACT=$G(Y)
Q
;
RETRY ; try to resend of complete message to PPS-N within one hour
W !,"There was a problem and the data file was not completed in PPS-N side."
W !,"The completion message will be automatically resent to PPS-N until the message is successfully transmitted or one hour has elapsed.",!
N ZTRTN,ZTIO,ZTDESC,ZTDTH,ZTSK
S ZTIO="",ZTRTN="NEWTRY^PSNPPSMS",ZTDESC="Automatic Resend of Complete message to PPS-N"
S ZTDTH=$H,ZTSAVE("FILE")="",ZTSAVE("DUZ")="" D ^%ZTLOAD I $D(ZTSK) W !!,"Queued as task #"_ZTSK K ZTSK
W !! K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to Continue" D ^DIR
Q
NEWTRY ; send of complete message to PPS-N
N PSNTXT,SDTM,ELAPS,DAY,XX,COMM,EDTM S SDTM=$H,(ELAPS,DAY,XX)=0
S:$D(ZTQUEUED) ZTREQ="@"
N1 S COMM=0 S COMM=$$SEND^PSNPPSNC("COMPLETED",$P(FILE,";"),"")
S EDTM=$H,DAY=+EDTM-(+SDTM)*86400 S XX=DAY+$P(EDTM,",",2)-$P(SDTM,",",2) I (XX\3600) S ELAPS=1
I (COMM+ELAPS)=0 G N1
; send mail message notification
S XMY(DUZ)="",XMSUB="PPS-N/NDF file ["_FILE_"] - COMPLETE message status"
S PSNTXT(1)=""
S PSNTXT(2)=$S(COMM=0:"There was a problem and the data file was not completed in PPS-N side.",COMM=1:"Complete message was sent to PPS-N. File should be approved/rejected.",1:"")
S XMDUZ=.5,XMTEXT="PSNTXT("
D ^XMD
Q
CTRLFILE(FILE) ;PROCESS CONTROL FILE, FILE NUMBER
K FDA
S FDA(57.231,CTRLXIEN_","_CTRLIEN_",",3)=FILE
D UPDATE^DIE("","FDA","CTRLIEN")
K FDA
Q
;
CTRLIEN(IENS) ;PROCESS CONTROL FILE, IENS
K FDA
S FDA(57.231,CTRLXIEN_","_CTRLIEN_",",4)=IENS
D UPDATE^DIE("","FDA","CTRLIEN")
K FDA
Q
;
CTRLSS(SS) ;PROCESS CONTROL FILE, SUBSCRIPT
K FDA
S FDA(57.231,CTRLXIEN_","_CTRLIEN_",",5)=$TR($TR(SS,""""),")")
D UPDATE^DIE("","FDA","CTRLIEN")
K FDA
Q
;
CTRKDL(DSPLY) ;PROCESS CONTROLL FILE, DISPLAYED LAST
K FDA
S FDA(57.231,CTRLXIEN_","_CTRLIEN_",",7)=DSPLY
D UPDATE^DIE("","FDA","CTRLIEN")
K FDA
;
RESOP ;Restarting option and protocol which were paused during install
Q:'$D(^TMP("PSNCON",$J))
N FL,IEN,DIE,DA,DR
S FL=0
F S FL=$O(^TMP("PSNCON",$J,FL)) Q:FL="" D
.S IEN=0
.F S IEN=$O(^TMP("PSNCON",$J,FL,IEN)) Q:IEN="" D
..S DIE=FL,DA=IEN,DR="2///@"
..D ^DIE
Q
;
LOAD1 ;BUILD THE MESSAGE
N PSNFIRST,PSNWP,DIWL,DIWR,J,NA
S FDA(57.231,CTRLXIEN_","_CTRLIEN_",",6)="TEXT"
D UPDATE^DIE("","FDA","CTRLIEN")
K FDA
S DIWL=1,DIWR=78 K ^UTILITY($J,"W")
S ^TMP("PSN",$J,LINE,0)=" ",LINE=LINE+1
S X="The following "_$S(INDX="A":"active",INDX="X":"investigational",1:"inactive")_" entries in your DRUG file (#50) have been" D ^DIWP
S J=0 F S J=$O(^TMP("PSN PPSN PARSED",$J,"TEXT",J)) Q:'J S X=^TMP("PSN PPSN PARSED",$J,"TEXT",J) D ^DIWP
S J=0 F S J=$O(^UTILITY($J,"W",DIWL,J)) Q:J="" S ^TMP("PSN",$J,LINE,0)=^UTILITY($J,"W",DIWL,J,0),LINE=LINE+1
K ^UTILITY($J,"W")
S ^TMP("PSN",$J,LINE,0)=" ",LINE=LINE+1
S NA="" I $O(^TMP($J,INDX,NA))="" S ^TMP("PSN",$J,LINE,0)=" NONE",LINE=LINE+1 Q
S PSNFIRST=0,NA=""
F S NA=$O(^TMP($J,INDX,NA)) Q:NA="" D
.I 'PSNFIRST D
..S ^TMP("PSN",$J,LINE,0)="DRUG IEN INACTIVATION",LINE=LINE+1
..S ^TMP("PSN",$J,LINE,0)=" DATE",LINE=LINE+1
..S PSNFIRST=1
.S X=^TMP($J,INDX,NA,1),^TMP("PSN",$J,LINE,0)=$P(NA,"^") S $E(^TMP("PSN",$J,LINE,0),55)=$P(NA,"^",2)
.S:INDX="I" $E(^(0),62)=$$FMTE^XLFDT($P(NA,"^",3),5) S LINE=LINE+1,^TMP("PSN",$J,LINE,0)=$P(X,"^"),LINE=LINE+1
.S J=1 F S J=$O(^TMP($J,INDX,NA,J)) Q:'J S ^TMP("PSN",$J,LINE,0)=^(J),LINE=LINE+1
Q
;
HAZWASTE ;AFTER POPULATION OF HAZ WASTE FIELDS - CREATE DELIMITED FILE
N PSWRKDIR,POP,IEN,HAZTODIS,PRIMESC,WASTE,DOTSC,X,NAME,HAZTOHAN,DATA,PSCOMFIL,PSRC,PSVUID
S PSWRKDIR="",PSWRKDIR=$$GETD^PSNFTP()
S PSCOMFIL="PSNHAZW.TXT"
DO OPEN^%ZISH("FILE1",PSWRKDIR,PSCOMFIL,"W")
IF POP DO QUIT
. SET PSRC="0^failed to open ftp .com file"
;
S (POP,IEN,HAZTODIS,PRIMESC,WASTE,DOTSC,X,NAME,HAZTOHAN,PSVUID)=""
DO USE^%ZISUTL("FILE1")
W "VA PRODUCT IEN^NAME^HAZARDOUS TO HANDLE^HAZARDOUS TO DISPOSE^PRIMARY EPA CODE^WASTE SORT CODE^DOT SHIPPING CODE^VUID",!
F S IEN=$O(^PSNDF(50.68,IEN)) Q:'IEN&(IEN'?1N.N) D
.S X="",X=$G(^PSNDF(50.68,IEN,"HAZTODIS"))
.;Q:$P(X,"^")'="Y"
.S (DOTSC,NAME)="",NAME=$$GET1^DIQ(50.68,IEN,.01,"E"),PSVUID=$$GET1^DIQ(50.68,IEN,99.99)
.S HAZTODIS=$$GET1^DIQ(50.68,IEN,102),PRIMESC=$P(X,"^",2),WASTE=$P(X,"^",3),HAZTOHAN=$$GET1^DIQ(50.68,IEN,101)
.I $D(^PSNDF(50.68,IEN,"HAZTODIS2",1,0)) S DOTSC=^PSNDF(50.68,IEN,"HAZTODIS2",1,0)
.S DATA=IEN_"^"_NAME_"^"_HAZTOHAN_"^"_HAZTODIS_"^"_PRIMESC_"^"_WASTE_"^"_DOTSC_"^"_PSVUID
.W DATA,!
DO CLOSE^%ZISH("FILE1")
Q
;
QUEST ;
N XX,X2,X22,QUEST,PSLAST,FIRST,PSNEW,PSFLG,PSFILES,PSFILE,PSNEXT,QCNT,DIRUT,DUOUT,DTOUT
S PSFLG="",PSLAST=$$GET1^DIQ(57.23,1,2)
S PSNEW=PSLAST+1,QCNT=0
S PSFILE="PPS_"_PSLAST_"PRV_"_PSNEW_"NEW.DAT"
S PSNEXT="PPS_"_PSNEW_"PRV_"_(PSNEW+1)_"NEW.DAT"
S (XX,X2,X22,QUEST)=""
F S X2=$O(B1(X2)) Q:X2="" S X22=$G(B1(X2)) D
.I '$G(QCNT) W !!,"The following PPS-N/NDF Update file(s) are available for install: ",! S QCNT=1
.I ($P($P(X22,"PRV"),"_",2))<PSLAST K B1(X2) Q
.S XX=XX+1 W !?5,XX_")",?12,$P(X22,";") S PSFILES(99999999+(+$P(X22,"_",2)))=X22
W !
I '$G(XX) W !,?5,"There are no files to install.",! R !!,"Enter to continue... ",ENTER:60 S QUIT2=1 Q
I XX>1 D QUESTA
Q
;
QUESTA ;
W !,"The files must be installed in sequential order and take around"
W !,"30 minutes each to install. Pharmacy will be down for that period"
W !,"of time. Do you want to install just the first one or all of them?"
QUESTB ;
R !!,"(F)irst file only or (A)ll files: ",QUEST:120
I QUEST["^"!($G(DIRUT))!($G(DUOUT)) W !!,"No action taken.",! S QUIT2=1 Q
I QUEST["?"!("FAfa"'[QUEST) W !!,"Enter F to install only the first file or A to install all files." G QUESTB
QUESTC ;
F S X2=$O(B1(X2)) Q:X2="" S X22=$G(B1(X2)) I '$D(PSFILES(X2)) K B1(X2)
I "Ff"[QUEST D
.S (X2,FIRST)="",FIRST=$O(PSFILES(FIRST))
.F S X2=$O(B1(X2)) Q:X2="" S X22=$G(B1(X2)) I X22'=$G(PSFILES(FIRST)) K B1(X2)
.W !!,"Only the first entry will be installed.",! S QUIT2=""
Q
;
DISMNU ;disable menu options
N PSREASON,Y,SEQ,NAM
W:'$G(PSNSCJOB) !,"Disabling mandatory options... " D NOW^%DTC S Y=% X ^DD("DD") W Y,!
S PSREASON="",PSREASON="PPS-N/NDF Update installation"
D OUT^XPDMENU("PSO LM BACKDOOR ORDERS",PSREASON)
D OUT^XPDMENU("PSO RELEASE",PSREASON)
D OUT^XPDMENU("PSO RXRPT",PSREASON)
D OUT^XPDMENU("PSNPMIS PRINT",PSREASON)
W:'$G(PSNSCJOB) !!,"Disabling user defined Scheduled Options... "
S (SEQ,IEN)="0"
F S SEQ=$O(^PS(57.23,1,3,"B",SEQ)) Q:SEQ="" S NAM=$$GET1^DIQ(19.2,SEQ,.01,"E") W !?5,NAM D DISOUT(NAM,PSREASON)
W:'$G(PSNSCJOB) !!,"Disabling user defined Menu Options... "
F S SEQ=$O(^PS(57.23,1,3.1,"B",SEQ)) Q:SEQ="" S NAM=$$GET1^DIQ(19,SEQ,.01,"E") W !?5,NAM D DISOUT(NAM,PSREASON)
W:'$G(PSNSCJOB) !!,"Disabling user defined Protocols... " ;D NOW^%DTC S Y=% X ^DD("DD") W Y,!
F S SEQ=$O(^PS(57.23,1,3.2,"B",SEQ)) Q:SEQ="" S NAM=$$GET1^DIQ(101,SEQ,.01,"E") W !?5,NAM D
.S $P(^ORD(101,SEQ,0),U,3)=PSREASON ;ZQOO1
Q
;
DISOUT(NAM,PSREASON) ;
D OUT^XPDMENU(NAM,PSREASON)
Q
ENABLE ;enable menu options
N Y,PSREASON
S PSREASON=""
W:'$G(PSNSCJOB) !,"Enabling options..."
D OUT^XPDMENU("PSO LM BACKDOOR ORDERS","")
D OUT^XPDMENU("PSO RELEASE","")
D OUT^XPDMENU("PSO RXRPT","")
D OUT^XPDMENU("PSNPMIS PRINT","")
D NOW^%DTC S Y=% X ^DD("DD") W:'$G(PSNSCJOB) Y,!
W:'$G(PSNSCJOB) !!,"Enabling user defined Scheduled Options... "
S (SEQ,IEN)=""
F S SEQ=$O(^PS(57.23,1,3,"B",SEQ)) Q:SEQ="" S NAM=$$GET1^DIQ(19.2,SEQ,.01,"E") W !?5,NAM D DISOUT(NAM,PSREASON)
W:'$G(PSNSCJOB) !!,"Enabling user defined Menu Options... "
F S SEQ=$O(^PS(57.23,1,3.1,"B",SEQ)) Q:SEQ="" S NAM=$$GET1^DIQ(19,SEQ,.01,"E") W !?5,NAM D DISOUT(NAM,PSREASON)
W:'$G(PSNSCJOB) !!,"Enabling user defined Protocols... "
F S SEQ=$O(^PS(57.23,1,3.2,"B",SEQ)) Q:SEQ="" S NAM=$$GET1^DIQ(101,SEQ,.01,"E") W !?5,NAM D
.S $P(^ORD(101,SEQ,0),U,3)=""
W !,"Options and protocols enabled: " D NOW^%DTC S Y=% X ^DD("DD") W Y,!
Q
ENABLE2(NAM,PSREASON) ;
D OUT^XPDMENU(NAM,PSREASON)
Q
;
ERRORMS ;FILE ERRORS ENCOUNTERED
N PSNEFIL,PSNEIEN,PSNEEN,PSNEUFS,PSNEFLD,PSNESEQ,PSNESEQ2,PSMSGTXT,PSNEX,PSNECNT,PSNECNT2
D NOW^%DTC
S (PSNEUFS,PSNEFIL,PSNEIEN,PSNEFLD,PSNESEQ,PSNECNT,PSNECNT2,PSNEX)=""
I $D(^TMP("PSN PPSN ERR",$J))&($D(^PS(57.23,1))) F S PSNEUFS=$O(^TMP("PSN PPSN ERR",$J,PSNEUFS)) Q:PSNEUFS="" D
.F S PSNEFIL=$O(^TMP("PSN PPSN ERR",$J,PSNEUFS,PSNEFIL)) Q:PSNEFIL="" D
..F S PSNEIEN=$O(^TMP("PSN PPSN ERR",$J,PSNEUFS,PSNEFIL,PSNEIEN)) Q:PSNEIEN="" D
...F S PSNEFLD=$O(^TMP("PSN PPSN ERR",$J,PSNEUFS,PSNEFIL,PSNEIEN,PSNEFLD)) Q:PSNEFLD="" D
....F S PSNESEQ=$O(^TMP("PSN PPSN ERR",$J,PSNEUFS,PSNEFIL,PSNEIEN,PSNEFLD,PSNESEQ)) Q:PSNESEQ="" D
.....S PSNEX=^TMP("PSN PPSN ERR",$J,PSNEUFS,PSNEFIL,PSNEIEN,PSNEFLD,PSNESEQ)
.....S PSNECNT=99999999999,PSNECNT=$O(^PS(57.23,1,5,PSNECNT),-1)
.....I '$D(PSNECNT) S ^PS(57.23,1,5,PSNECNT,2,0)="^57.23D^1^1"
.....S PSNECNT2=99999999999,PSNECNT2=$O(^PS(57.23,1,5,PSNECNT,2,PSNECNT2),-1)
.....S PSNECNT2=PSNECNT2+1
.....S ^PS(57.23,1,5,PSNECNT,2,PSNECNT2,0)=%_"^"_PSNEFIL_"^"_PSNEIEN_"^"_PSNEUFS_"^"_PSNEX
Q
;
ASK(FILE) ; check if the file has been finalized
;LSTD - Last Download version
;
N NFILE,LSTD,PSI
S PSI=0
S PSI=$O(^PS(57.23,1,4,"G",$P(FILE,";"),""),-1) I 'PSI Q "0^0"
I PSI S LSTD=$G(^PS(57.23,1,4,"G",$P(FILE,";"),PSI)),NFILE=FILE_";"_LSTD
I $D(^PS(57.23,1,6,"B",NFILE)) W !!,"WARNING: File has been rejected and finalized. It's not recommended to",!,?9,"reject it again."
Q PSI_"^"_LSTD
;
ASK1(FILE) ; check if the file has been previously installed
N NFILE,LSTD,LSTI,PSI
S (PSI,LSTD,LSTI)=0
S PSI=$O(^PS(57.23,1,4,"G",$P(FILE,";"),""),-1) I 'PSI Q 0
S LSTD=$G(^PS(57.23,1,4,"G",$P(FILE,";"),PSI)),NFILE=FILE_";"_LSTD
S LSTI=$O(^PS(57.23,1,5,"B",NFILE,0))
Q LSTI
;
REJUPD(FILE) ; update reject history node
K FDA
N PSI,LSTD S LSTD=1
S FDA(57.236,"+2,"_1_",",.01)=FILE D UPDATE^DIE("","FDA")
K IEN6,%,FDA
S IEN6=$O(^PS(57.23,1,6,"B",FILE,""),-1)
D NOW^%DTC
S FDA(57.236,IEN6_","_1_",",1)=%,FDA(57.236,IEN6_","_1_",",2)=DUZ D UPDATE^DIE("","FDA")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSNPPSMS 15142 printed Sep 23, 2025@20:00:44 Page 2
PSNPPSMS ;HP/LE-PPSN update NDFK ; 05 Mar 2014 1:20 PM
+1 ;;4.0;NATIONAL DRUG FILE;**513**; 30 Oct 98;Build 53
+2 ;Reference to ^%ZISH supported by DBIA #2320
+3 ;
56(FILE,DIA,NEW,PSNTMPN) ;Drug Interaction file (#56) changes into 5000.561
+1 ;5000.561 = inactivated drug interactions
+2 ;5000.56 = added and edited drug interactions
+3 ;
+4 NEW DIC,DIE,DD,DO,DINUM,DA,FDA,NDFIEN,FLD1,TYPE,PSNPS,STAT
+5 SET PSNPS=$PIECE($GET(^PS(59.7,1,10)),"^",12)
if PSNPS'="N"
QUIT
+6 SET FLD1=$PIECE(DIA,"^",3)
SET NDFIEN=+DIA
+7 SET STAT=""
SET STAT=$SELECT((FLD1=7&(NEW'="")):"I",PSNTMPN="DATAN":"A",PSNTMPN="DATAO":"E",1:"")
+8 IF '$DATA(^NDFK(5000.56,$PIECE(DIA,"^")))
Begin DoDot:1
+9 SET DIC="^NDFK(5000.56,"
SET DIC(0)="Z"
SET (X,DINUM)=$PIECE(DIA,"^")
DO FILE^DICN
+10 SET DIE=DIC
SET DA=+Y
KILL DIC
+11 SET DA=+$PIECE(DIA,"^")
SET DIE="^NDFK(5000.56,"
SET DR="1///"_STAT
DO ^DIE
End DoDot:1
+12 IF $DATA(^NDFK(5000.56,$PIECE(DIA,"^")))
Begin DoDot:1
+13 SET DIC="^NDFK(5000.56,"
SET DA=+$PIECE(DIA,"^")
SET DIE="^NDFK(5000.56,"
SET DR="1///"_STAT
DO ^DIE
End DoDot:1
+14 QUIT
+15 ;
IGU ;For National VistA Test SQA use only
+1 ;When a PPS-N Update file cannot be installed in the National VistA Test SQA account, use this option to reject the file.
+2 ;Local VA production sites or product test accounts should NEVER use this option. If you do, your NDF files
+3 ;will be out of sync and may cause irreparable damage. This is for SQA to reject corrupted files before they are nationally released.
+4 NEW COMM,FILE,ANS,PARAM,ENTER,II,FLG,ACT,TYPE,PSNLEGF,ZTQUEUED,ZTREQ,IOBOFF,IOBON
+5 SET (ACT,TYPE,PARAM)=""
SET PARAM=$$GET1^DIQ(59.7,1,17,"I")
+6 ;
IGU2 ;
+1 SET PSNLEGF=""
SET PSNLEGF=$$LEGACY^PSNPPSDL()
IF PSNLEGF
QUIT
+2 SET TYPE=$SELECT("^P^T^S^"[("^"_PARAM_"^"):"C",1:"CR")
+3 WRITE !!
+4 ;only show for local sites, product support, local site test accounts
IF TYPE="C"
WRITE "Note: Local sites may send completion messages for PPSN Update files, but may"
Begin DoDot:1
+5 WRITE !,"not utilize the Reject Update File functionality as it is for National QA only.",!!
End DoDot:1
+6 KILL DIR
SET DIR(0)="F^17:40^I X'?1""PPS_""1.12N1""PRV_""1.12N1""NEW.DAT"" K X"
+7 SET DIR("A")="Enter the PPS-N data file name to be "_$SELECT(TYPE="CR":"Updated",1:"Completed")
+8 SET DIR("?",1)=" Enter the PPS-N Update file name that cannot be installed."
+9 SET DIR("?")=" The file format should be PPS_nnPRV_nnNEW.DAT."
DO ^DIR
KILL DIR
SET FILE=Y
+10 IF (FILE="")!$DATA(DTOUT)!$DATA(DUOUT)
QUIT
+11 SET (II,FLG)=0
FOR
SET II=$ORDER(^PS(57.23,1,4,"B",FILE,II))
if 'II
QUIT
IF $PIECE($GET(^PS(57.23,1,4,II,0)),"^",4)]""
SET FLG=1
+12 IF FLG=0
WRITE !!!,$GET(IOBON),"WARNING:",$GET(IOBOFF)," The selected file hasn't been downloaded in VistA. It must be ",!,?9,"downloaded before you can be take action.",$CHAR(7)
QUIT
+13 IF +$PIECE(FILE,"_",2)'=($$GET1^DIQ(57.23,1,8)-1)
WRITE !!!,$GET(IOBON),"WARNING:",$GET(IOBOFF)," Reject isn't allowed for Update files older than the current",!,?9,"downloaded version",$CHAR(7)
READ !!,"Enter to continue... ",ENTER:60
QUIT
+14 ;
+15 IF TYPE="CR"
DO ACTION
IF ACT="^"
WRITE !!,"No action taken."
QUIT
+16 SET ACT=$SELECT(TYPE="C":"C",1:ACT)
+17 IF ACT="C"
Begin DoDot:1
+18 SET COMM=""
SET COMM=$$SEND^PSNPPSNC("COMPLETED",$PIECE(FILE,";"),"")
HANG 1
WRITE !!
Begin DoDot:2
+19 IF COMM=1
WRITE !,"Complete message was sent to PPS-N. File should be approved/rejected ",!,"in PPS-N side.",!
+20 ;E W !,"There was a problem and the data file was not completed in PPS-N side."
+21 IF 'COMM
DO RETRY
End DoDot:2
End DoDot:1
DO CONT
QUIT
+22 ;
RJ ; execute file rejection
+1 NEW NFF
SET NFF=$$ASK(FILE)
IF $ORDER(^PS(57.23,1,"B",$PIECE(FILE,";")_";"_$PIECE(NFF,"^",2),""),-1)
IF PARAM'="Q"
WRITE !!,"No action taken."
QUIT
+2 WRITE !
KILL DIR
SET DIR("A")="Are you sure you want to reject file '"_FILE_"'"
SET DIR("B")="NO"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+3 SET ANS=Y
IF 'ANS
WRITE !!,"No action taken."
QUIT
+4 WRITE !
+5 ; send message to PPS-N - REJECTED processing
+6 SET COMM=""
SET COMM=$$SEND^PSNPPSNC("ERROR",$PIECE(FILE,";"),"Automatically Rejected: Unable to Install Update File in the Test Account")
HANG 1
+7 IF 'COMM
Begin DoDot:1
+8 WRITE !?11,"*** ERROR: "_$PIECE(COMM,"^",2)
+9 WRITE !!?11,"PPS-N did not accept the REJECT transmission for "
+10 WRITE !?11,FILE_"."
+11 WRITE !!?11,"Contact your IRM and ask them to validate that the UPDATE_STATUS"
+12 WRITE !?11,"web service manager is defined under the Web Server Name PPSN"
+13 WRITE !?11,"and that it is active. Also verify that the Pharmacy Product"
+14 WRITE !?11,"System-National (PPS-N) is on-line.",!!
End DoDot:1
GOTO IGU2
+15 IF COMM
WRITE !!,FILE," has been automatically rejected in PPS-N.",!
SET $PIECE(^PS(57.23,1,0),"^",7)=+$PIECE(FILE,"_",2)
Begin DoDot:1
+16 IF $PIECE(NFF,"^",2)
DO REJUPD(FILE_";"_$PIECE(NFF,"^",2))
End DoDot:1
+17 ;
CONT ;
+1 KILL DIR
SET DIR(0)="E"
SET DIR("?")="Press Return to continue"
SET DIR("A")="Press Return to Continue"
DO ^DIR
+2 QUIT
ACTION ; prompt user for action type (complete/reject)
+1 IF $$ASK1(FILE)
SET ACT="C"
QUIT
+2 WRITE !
KILL DIR,ACT
SET DIR("A")="Action"
SET DIR(0)="S^C:Complete data file;R:Reject data file"
SET DIR("B")="C"
+3 SET DIR("?")="Enter 'R' to reject the data file in PPS-N and retain the data for next update file version. Enter 'C' to changes the status in PPS-N which allows the user to notify PPS-N that the installation completed."
+4 DO ^DIR
SET ACT=$GET(Y)
+5 QUIT
+6 ;
RETRY ; try to resend of complete message to PPS-N within one hour
+1 WRITE !,"There was a problem and the data file was not completed in PPS-N side."
+2 WRITE !,"The completion message will be automatically resent to PPS-N until the message is successfully transmitted or one hour has elapsed.",!
+3 NEW ZTRTN,ZTIO,ZTDESC,ZTDTH,ZTSK
+4 SET ZTIO=""
SET ZTRTN="NEWTRY^PSNPPSMS"
SET ZTDESC="Automatic Resend of Complete message to PPS-N"
+5 SET ZTDTH=$HOROLOG
SET ZTSAVE("FILE")=""
SET ZTSAVE("DUZ")=""
DO ^%ZTLOAD
IF $DATA(ZTSK)
WRITE !!,"Queued as task #"_ZTSK
KILL ZTSK
+6 WRITE !!
KILL DIR
SET DIR(0)="E"
SET DIR("?")="Press Return to continue"
SET DIR("A")="Press Return to Continue"
DO ^DIR
+7 QUIT
NEWTRY ; send of complete message to PPS-N
+1 NEW PSNTXT,SDTM,ELAPS,DAY,XX,COMM,EDTM
SET SDTM=$HOROLOG
SET (ELAPS,DAY,XX)=0
+2 if $DATA(ZTQUEUED)
SET ZTREQ="@"
N1 SET COMM=0
SET COMM=$$SEND^PSNPPSNC("COMPLETED",$PIECE(FILE,";"),"")
+1 SET EDTM=$HOROLOG
SET DAY=+EDTM-(+SDTM)*86400
SET XX=DAY+$PIECE(EDTM,",",2)-$PIECE(SDTM,",",2)
IF (XX\3600)
SET ELAPS=1
+2 IF (COMM+ELAPS)=0
GOTO N1
+3 ; send mail message notification
+4 SET XMY(DUZ)=""
SET XMSUB="PPS-N/NDF file ["_FILE_"] - COMPLETE message status"
+5 SET PSNTXT(1)=""
+6 SET PSNTXT(2)=$SELECT(COMM=0:"There was a problem and the data file was not completed in PPS-N side.",COMM=1:"Complete message was sent to PPS-N. File should be approved/rejected.",1:"")
+7 SET XMDUZ=.5
SET XMTEXT="PSNTXT("
+8 DO ^XMD
+9 QUIT
CTRLFILE(FILE) ;PROCESS CONTROL FILE, FILE NUMBER
+1 KILL FDA
+2 SET FDA(57.231,CTRLXIEN_","_CTRLIEN_",",3)=FILE
+3 DO UPDATE^DIE("","FDA","CTRLIEN")
+4 KILL FDA
+5 QUIT
+6 ;
CTRLIEN(IENS) ;PROCESS CONTROL FILE, IENS
+1 KILL FDA
+2 SET FDA(57.231,CTRLXIEN_","_CTRLIEN_",",4)=IENS
+3 DO UPDATE^DIE("","FDA","CTRLIEN")
+4 KILL FDA
+5 QUIT
+6 ;
CTRLSS(SS) ;PROCESS CONTROL FILE, SUBSCRIPT
+1 KILL FDA
+2 SET FDA(57.231,CTRLXIEN_","_CTRLIEN_",",5)=$TRANSLATE($TRANSLATE(SS,""""),")")
+3 DO UPDATE^DIE("","FDA","CTRLIEN")
+4 KILL FDA
+5 QUIT
+6 ;
CTRKDL(DSPLY) ;PROCESS CONTROLL FILE, DISPLAYED LAST
+1 KILL FDA
+2 SET FDA(57.231,CTRLXIEN_","_CTRLIEN_",",7)=DSPLY
+3 DO UPDATE^DIE("","FDA","CTRLIEN")
+4 KILL FDA
+5 ;
RESOP ;Restarting option and protocol which were paused during install
+1 if '$DATA(^TMP("PSNCON",$JOB))
QUIT
+2 NEW FL,IEN,DIE,DA,DR
+3 SET FL=0
+4 FOR
SET FL=$ORDER(^TMP("PSNCON",$JOB,FL))
if FL=""
QUIT
Begin DoDot:1
+5 SET IEN=0
+6 FOR
SET IEN=$ORDER(^TMP("PSNCON",$JOB,FL,IEN))
if IEN=""
QUIT
Begin DoDot:2
+7 SET DIE=FL
SET DA=IEN
SET DR="2///@"
+8 DO ^DIE
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
LOAD1 ;BUILD THE MESSAGE
+1 NEW PSNFIRST,PSNWP,DIWL,DIWR,J,NA
+2 SET FDA(57.231,CTRLXIEN_","_CTRLIEN_",",6)="TEXT"
+3 DO UPDATE^DIE("","FDA","CTRLIEN")
+4 KILL FDA
+5 SET DIWL=1
SET DIWR=78
KILL ^UTILITY($JOB,"W")
+6 SET ^TMP("PSN",$JOB,LINE,0)=" "
SET LINE=LINE+1
+7 SET X="The following "_$SELECT(INDX="A":"active",INDX="X":"investigational",1:"inactive")_" entries in your DRUG file (#50) have been"
DO ^DIWP
+8 SET J=0
FOR
SET J=$ORDER(^TMP("PSN PPSN PARSED",$JOB,"TEXT",J))
if 'J
QUIT
SET X=^TMP("PSN PPSN PARSED",$JOB,"TEXT",J)
DO ^DIWP
+9 SET J=0
FOR
SET J=$ORDER(^UTILITY($JOB,"W",DIWL,J))
if J=""
QUIT
SET ^TMP("PSN",$JOB,LINE,0)=^UTILITY($JOB,"W",DIWL,J,0)
SET LINE=LINE+1
+10 KILL ^UTILITY($JOB,"W")
+11 SET ^TMP("PSN",$JOB,LINE,0)=" "
SET LINE=LINE+1
+12 SET NA=""
IF $ORDER(^TMP($JOB,INDX,NA))=""
SET ^TMP("PSN",$JOB,LINE,0)=" NONE"
SET LINE=LINE+1
QUIT
+13 SET PSNFIRST=0
SET NA=""
+14 FOR
SET NA=$ORDER(^TMP($JOB,INDX,NA))
if NA=""
QUIT
Begin DoDot:1
+15 IF 'PSNFIRST
Begin DoDot:2
+16 SET ^TMP("PSN",$JOB,LINE,0)="DRUG IEN INACTIVATION"
SET LINE=LINE+1
+17 SET ^TMP("PSN",$JOB,LINE,0)=" DATE"
SET LINE=LINE+1
+18 SET PSNFIRST=1
End DoDot:2
+19 SET X=^TMP($JOB,INDX,NA,1)
SET ^TMP("PSN",$JOB,LINE,0)=$PIECE(NA,"^")
SET $EXTRACT(^TMP("PSN",$JOB,LINE,0),55)=$PIECE(NA,"^",2)
+20 if INDX="I"
SET $EXTRACT(^(0),62)=$$FMTE^XLFDT($PIECE(NA,"^",3),5)
SET LINE=LINE+1
SET ^TMP("PSN",$JOB,LINE,0)=$PIECE(X,"^")
SET LINE=LINE+1
+21 SET J=1
FOR
SET J=$ORDER(^TMP($JOB,INDX,NA,J))
if 'J
QUIT
SET ^TMP("PSN",$JOB,LINE,0)=^(J)
SET LINE=LINE+1
End DoDot:1
+22 QUIT
+23 ;
HAZWASTE ;AFTER POPULATION OF HAZ WASTE FIELDS - CREATE DELIMITED FILE
+1 NEW PSWRKDIR,POP,IEN,HAZTODIS,PRIMESC,WASTE,DOTSC,X,NAME,HAZTOHAN,DATA,PSCOMFIL,PSRC,PSVUID
+2 SET PSWRKDIR=""
SET PSWRKDIR=$$GETD^PSNFTP()
+3 SET PSCOMFIL="PSNHAZW.TXT"
+4 DO OPEN^%ZISH("FILE1",PSWRKDIR,PSCOMFIL,"W")
+5 IF POP
Begin DoDot:1
+6 SET PSRC="0^failed to open ftp .com file"
End DoDot:1
QUIT
+7 ;
+8 SET (POP,IEN,HAZTODIS,PRIMESC,WASTE,DOTSC,X,NAME,HAZTOHAN,PSVUID)=""
+9 DO USE^%ZISUTL("FILE1")
+10 WRITE "VA PRODUCT IEN^NAME^HAZARDOUS TO HANDLE^HAZARDOUS TO DISPOSE^PRIMARY EPA CODE^WASTE SORT CODE^DOT SHIPPING CODE^VUID",!
+11 FOR
SET IEN=$ORDER(^PSNDF(50.68,IEN))
if 'IEN&(IEN'?1N.N)
QUIT
Begin DoDot:1
+12 SET X=""
SET X=$GET(^PSNDF(50.68,IEN,"HAZTODIS"))
+13 ;Q:$P(X,"^")'="Y"
+14 SET (DOTSC,NAME)=""
SET NAME=$$GET1^DIQ(50.68,IEN,.01,"E")
SET PSVUID=$$GET1^DIQ(50.68,IEN,99.99)
+15 SET HAZTODIS=$$GET1^DIQ(50.68,IEN,102)
SET PRIMESC=$PIECE(X,"^",2)
SET WASTE=$PIECE(X,"^",3)
SET HAZTOHAN=$$GET1^DIQ(50.68,IEN,101)
+16 IF $DATA(^PSNDF(50.68,IEN,"HAZTODIS2",1,0))
SET DOTSC=^PSNDF(50.68,IEN,"HAZTODIS2",1,0)
+17 SET DATA=IEN_"^"_NAME_"^"_HAZTOHAN_"^"_HAZTODIS_"^"_PRIMESC_"^"_WASTE_"^"_DOTSC_"^"_PSVUID
+18 WRITE DATA,!
End DoDot:1
+19 DO CLOSE^%ZISH("FILE1")
+20 QUIT
+21 ;
QUEST ;
+1 NEW XX,X2,X22,QUEST,PSLAST,FIRST,PSNEW,PSFLG,PSFILES,PSFILE,PSNEXT,QCNT,DIRUT,DUOUT,DTOUT
+2 SET PSFLG=""
SET PSLAST=$$GET1^DIQ(57.23,1,2)
+3 SET PSNEW=PSLAST+1
SET QCNT=0
+4 SET PSFILE="PPS_"_PSLAST_"PRV_"_PSNEW_"NEW.DAT"
+5 SET PSNEXT="PPS_"_PSNEW_"PRV_"_(PSNEW+1)_"NEW.DAT"
+6 SET (XX,X2,X22,QUEST)=""
+7 FOR
SET X2=$ORDER(B1(X2))
if X2=""
QUIT
SET X22=$GET(B1(X2))
Begin DoDot:1
+8 IF '$GET(QCNT)
WRITE !!,"The following PPS-N/NDF Update file(s) are available for install: ",!
SET QCNT=1
+9 IF ($PIECE($PIECE(X22,"PRV"),"_",2))<PSLAST
KILL B1(X2)
QUIT
+10 SET XX=XX+1
WRITE !?5,XX_")",?12,$PIECE(X22,";")
SET PSFILES(99999999+(+$PIECE(X22,"_",2)))=X22
End DoDot:1
+11 WRITE !
+12 IF '$GET(XX)
WRITE !,?5,"There are no files to install.",!
READ !!,"Enter to continue... ",ENTER:60
SET QUIT2=1
QUIT
+13 IF XX>1
DO QUESTA
+14 QUIT
+15 ;
QUESTA ;
+1 WRITE !,"The files must be installed in sequential order and take around"
+2 WRITE !,"30 minutes each to install. Pharmacy will be down for that period"
+3 WRITE !,"of time. Do you want to install just the first one or all of them?"
QUESTB ;
+1 READ !!,"(F)irst file only or (A)ll files: ",QUEST:120
+2 IF QUEST["^"!($GET(DIRUT))!($GET(DUOUT))
WRITE !!,"No action taken.",!
SET QUIT2=1
QUIT
+3 IF QUEST["?"!("FAfa"'[QUEST)
WRITE !!,"Enter F to install only the first file or A to install all files."
GOTO QUESTB
QUESTC ;
+1 FOR
SET X2=$ORDER(B1(X2))
if X2=""
QUIT
SET X22=$GET(B1(X2))
IF '$DATA(PSFILES(X2))
KILL B1(X2)
+2 IF "Ff"[QUEST
Begin DoDot:1
+3 SET (X2,FIRST)=""
SET FIRST=$ORDER(PSFILES(FIRST))
+4 FOR
SET X2=$ORDER(B1(X2))
if X2=""
QUIT
SET X22=$GET(B1(X2))
IF X22'=$GET(PSFILES(FIRST))
KILL B1(X2)
+5 WRITE !!,"Only the first entry will be installed.",!
SET QUIT2=""
End DoDot:1
+6 QUIT
+7 ;
DISMNU ;disable menu options
+1 NEW PSREASON,Y,SEQ,NAM
+2 if '$GET(PSNSCJOB)
WRITE !,"Disabling mandatory options... "
DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
WRITE Y,!
+3 SET PSREASON=""
SET PSREASON="PPS-N/NDF Update installation"
+4 DO OUT^XPDMENU("PSO LM BACKDOOR ORDERS",PSREASON)
+5 DO OUT^XPDMENU("PSO RELEASE",PSREASON)
+6 DO OUT^XPDMENU("PSO RXRPT",PSREASON)
+7 DO OUT^XPDMENU("PSNPMIS PRINT",PSREASON)
+8 if '$GET(PSNSCJOB)
WRITE !!,"Disabling user defined Scheduled Options... "
+9 SET (SEQ,IEN)="0"
+10 FOR
SET SEQ=$ORDER(^PS(57.23,1,3,"B",SEQ))
if SEQ=""
QUIT
SET NAM=$$GET1^DIQ(19.2,SEQ,.01,"E")
WRITE !?5,NAM
DO DISOUT(NAM,PSREASON)
+11 if '$GET(PSNSCJOB)
WRITE !!,"Disabling user defined Menu Options... "
+12 FOR
SET SEQ=$ORDER(^PS(57.23,1,3.1,"B",SEQ))
if SEQ=""
QUIT
SET NAM=$$GET1^DIQ(19,SEQ,.01,"E")
WRITE !?5,NAM
DO DISOUT(NAM,PSREASON)
+13 ;D NOW^%DTC S Y=% X ^DD("DD") W Y,!
if '$GET(PSNSCJOB)
WRITE !!,"Disabling user defined Protocols... "
+14 FOR
SET SEQ=$ORDER(^PS(57.23,1,3.2,"B",SEQ))
if SEQ=""
QUIT
SET NAM=$$GET1^DIQ(101,SEQ,.01,"E")
WRITE !?5,NAM
Begin DoDot:1
+15 ;ZQOO1
SET $PIECE(^ORD(101,SEQ,0),U,3)=PSREASON
End DoDot:1
+16 QUIT
+17 ;
DISOUT(NAM,PSREASON) ;
+1 DO OUT^XPDMENU(NAM,PSREASON)
+2 QUIT
ENABLE ;enable menu options
+1 NEW Y,PSREASON
+2 SET PSREASON=""
+3 if '$GET(PSNSCJOB)
WRITE !,"Enabling options..."
+4 DO OUT^XPDMENU("PSO LM BACKDOOR ORDERS","")
+5 DO OUT^XPDMENU("PSO RELEASE","")
+6 DO OUT^XPDMENU("PSO RXRPT","")
+7 DO OUT^XPDMENU("PSNPMIS PRINT","")
+8 DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
if '$GET(PSNSCJOB)
WRITE Y,!
+9 if '$GET(PSNSCJOB)
WRITE !!,"Enabling user defined Scheduled Options... "
+10 SET (SEQ,IEN)=""
+11 FOR
SET SEQ=$ORDER(^PS(57.23,1,3,"B",SEQ))
if SEQ=""
QUIT
SET NAM=$$GET1^DIQ(19.2,SEQ,.01,"E")
WRITE !?5,NAM
DO DISOUT(NAM,PSREASON)
+12 if '$GET(PSNSCJOB)
WRITE !!,"Enabling user defined Menu Options... "
+13 FOR
SET SEQ=$ORDER(^PS(57.23,1,3.1,"B",SEQ))
if SEQ=""
QUIT
SET NAM=$$GET1^DIQ(19,SEQ,.01,"E")
WRITE !?5,NAM
DO DISOUT(NAM,PSREASON)
+14 if '$GET(PSNSCJOB)
WRITE !!,"Enabling user defined Protocols... "
+15 FOR
SET SEQ=$ORDER(^PS(57.23,1,3.2,"B",SEQ))
if SEQ=""
QUIT
SET NAM=$$GET1^DIQ(101,SEQ,.01,"E")
WRITE !?5,NAM
Begin DoDot:1
+16 SET $PIECE(^ORD(101,SEQ,0),U,3)=""
End DoDot:1
+17 WRITE !,"Options and protocols enabled: "
DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
WRITE Y,!
+18 QUIT
ENABLE2(NAM,PSREASON) ;
+1 DO OUT^XPDMENU(NAM,PSREASON)
+2 QUIT
+3 ;
ERRORMS ;FILE ERRORS ENCOUNTERED
+1 NEW PSNEFIL,PSNEIEN,PSNEEN,PSNEUFS,PSNEFLD,PSNESEQ,PSNESEQ2,PSMSGTXT,PSNEX,PSNECNT,PSNECNT2
+2 DO NOW^%DTC
+3 SET (PSNEUFS,PSNEFIL,PSNEIEN,PSNEFLD,PSNESEQ,PSNECNT,PSNECNT2,PSNEX)=""
+4 IF $DATA(^TMP("PSN PPSN ERR",$JOB))&($DATA(^PS(57.23,1)))
FOR
SET PSNEUFS=$ORDER(^TMP("PSN PPSN ERR",$JOB,PSNEUFS))
if PSNEUFS=""
QUIT
Begin DoDot:1
+5 FOR
SET PSNEFIL=$ORDER(^TMP("PSN PPSN ERR",$JOB,PSNEUFS,PSNEFIL))
if PSNEFIL=""
QUIT
Begin DoDot:2
+6 FOR
SET PSNEIEN=$ORDER(^TMP("PSN PPSN ERR",$JOB,PSNEUFS,PSNEFIL,PSNEIEN))
if PSNEIEN=""
QUIT
Begin DoDot:3
+7 FOR
SET PSNEFLD=$ORDER(^TMP("PSN PPSN ERR",$JOB,PSNEUFS,PSNEFIL,PSNEIEN,PSNEFLD))
if PSNEFLD=""
QUIT
Begin DoDot:4
+8 FOR
SET PSNESEQ=$ORDER(^TMP("PSN PPSN ERR",$JOB,PSNEUFS,PSNEFIL,PSNEIEN,PSNEFLD,PSNESEQ))
if PSNESEQ=""
QUIT
Begin DoDot:5
+9 SET PSNEX=^TMP("PSN PPSN ERR",$JOB,PSNEUFS,PSNEFIL,PSNEIEN,PSNEFLD,PSNESEQ)
+10 SET PSNECNT=99999999999
SET PSNECNT=$ORDER(^PS(57.23,1,5,PSNECNT),-1)
+11 IF '$DATA(PSNECNT)
SET ^PS(57.23,1,5,PSNECNT,2,0)="^57.23D^1^1"
+12 SET PSNECNT2=99999999999
SET PSNECNT2=$ORDER(^PS(57.23,1,5,PSNECNT,2,PSNECNT2),-1)
+13 SET PSNECNT2=PSNECNT2+1
+14 SET ^PS(57.23,1,5,PSNECNT,2,PSNECNT2,0)=%_"^"_PSNEFIL_"^"_PSNEIEN_"^"_PSNEUFS_"^"_PSNEX
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+15 QUIT
+16 ;
ASK(FILE) ; check if the file has been finalized
+1 ;LSTD - Last Download version
+2 ;
+3 NEW NFILE,LSTD,PSI
+4 SET PSI=0
+5 SET PSI=$ORDER(^PS(57.23,1,4,"G",$PIECE(FILE,";"),""),-1)
IF 'PSI
QUIT "0^0"
+6 IF PSI
SET LSTD=$GET(^PS(57.23,1,4,"G",$PIECE(FILE,";"),PSI))
SET NFILE=FILE_";"_LSTD
+7 IF $DATA(^PS(57.23,1,6,"B",NFILE))
WRITE !!,"WARNING: File has been rejected and finalized. It's not recommended to",!,?9,"reject it again."
+8 QUIT PSI_"^"_LSTD
+9 ;
ASK1(FILE) ; check if the file has been previously installed
+1 NEW NFILE,LSTD,LSTI,PSI
+2 SET (PSI,LSTD,LSTI)=0
+3 SET PSI=$ORDER(^PS(57.23,1,4,"G",$PIECE(FILE,";"),""),-1)
IF 'PSI
QUIT 0
+4 SET LSTD=$GET(^PS(57.23,1,4,"G",$PIECE(FILE,";"),PSI))
SET NFILE=FILE_";"_LSTD
+5 SET LSTI=$ORDER(^PS(57.23,1,5,"B",NFILE,0))
+6 QUIT LSTI
+7 ;
REJUPD(FILE) ; update reject history node
+1 KILL FDA
+2 NEW PSI,LSTD
SET LSTD=1
+3 SET FDA(57.236,"+2,"_1_",",.01)=FILE
DO UPDATE^DIE("","FDA")
+4 KILL IEN6,%,FDA
+5 SET IEN6=$ORDER(^PS(57.23,1,6,"B",FILE,""),-1)
+6 DO NOW^%DTC
+7 SET FDA(57.236,IEN6_","_1_",",1)=%
SET FDA(57.236,IEN6_","_1_",",2)=DUZ
DO UPDATE^DIE("","FDA")
+8 QUIT
