- 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 Feb 18, 2025@23:51:01 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